[Git][ghc/ghc][wip/az/T24714-GADT-sig-only-span] 6 commits: Make read accepts binary integer formats
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Tue Apr 30 07:48:07 UTC 2024
Alan Zimmerman pushed to branch wip/az/T24714-GADT-sig-only-span at Glasgow Haskell Compiler / GHC
Commits:
e2094df3 by damhiya at 2024-04-28T23:52:00+09:00
Make read accepts binary integer formats
CLC proposal : https://github.com/haskell/core-libraries-committee/issues/177
- - - - -
1c2fd963 by Alan Zimmerman at 2024-04-29T23:17:00-04:00
EPA: Preserve comments in Match Pats
Closes #24708
Closes #24715
Closes #24734
- - - - -
4189d17e by Sylvain Henry at 2024-04-29T23:17:42-04:00
LLVM: better unreachable default destination in Switch (#24717)
See added note.
Co-authored-by: Siddharth Bhat <siddu.druid at gmail.com>
- - - - -
a3725c88 by Cheng Shao at 2024-04-29T23:18:20-04:00
ci: enable wasm jobs for MRs with wasm label
This patch enables wasm jobs for MRs with wasm label. Previously the
wasm label didn't actually have any effect on the CI pipeline, and
full-ci needed to be applied to run wasm jobs which was a waste of
runners when working on the wasm backend, hence the fix here.
- - - - -
702f7964 by Matthew Pickering at 2024-04-29T23:18:56-04:00
Make interface files and object files depend on inplace .conf file
A potential fix for #24737
- - - - -
b62b36b4 by Alan Zimmerman at 2024-04-30T08:45:58+01:00
EPA: Fix range for GADT decl with sig only
Closes #24714
- - - - -
19 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- docs/users_guide/bugs.rst
- hadrian/src/Rules/Compile.hs
- libraries/base/changelog.md
- libraries/base/tests/char001.hs
- libraries/base/tests/char001.stdout
- libraries/base/tests/lex001.hs
- libraries/base/tests/lex001.stdout
- libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs
- + testsuite/tests/printer/DataDeclShort.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/MatchPatComments.hs
- testsuite/tests/printer/all.T
- utils/check-exact/Main.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -603,6 +603,7 @@ data ValidateRule =
FullCI -- ^ Run this job when the "full-ci" label is present.
| LLVMBackend -- ^ Run this job when the "LLVM backend" label is present
| JSBackend -- ^ Run this job when the "javascript" label is present
+ | WasmBackend -- ^ Run this job when the "wasm" label is present
| FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
| NonmovingGc -- ^ Run this job when the "non-moving GC" label is set.
| IpeData -- ^ Run this job when the "IPE" label is set
@@ -649,6 +650,7 @@ validateRuleString FullCI = or_all ([ labelString "full-ci"
validateRuleString LLVMBackend = labelString "LLVM backend"
validateRuleString JSBackend = labelString "javascript"
+validateRuleString WasmBackend = labelString "wasm"
validateRuleString FreeBSDLabel = labelString "FreeBSD"
validateRuleString NonmovingGc = labelString "non-moving GC"
validateRuleString IpeData = labelString "IPE"
@@ -1048,7 +1050,7 @@ job_groups =
. setVariable "HADRIAN_ARGS" "--docs=none"
. delVariable "INSTALL_CONFIGURE_ARGS"
)
- $ validateBuilds Amd64 (Linux AlpineWasm) cfg
+ $ addValidateRule WasmBackend $ validateBuilds Amd64 (Linux AlpineWasm) cfg
wasm_build_config =
(crossConfig "wasm32-wasi" NoEmulatorNeeded Nothing)
=====================================
.gitlab/jobs.yaml
=====================================
@@ -4502,7 +4502,7 @@
],
"rules": [
{
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*wasm.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "on_success"
}
],
@@ -4566,7 +4566,7 @@
"rules": [
{
"allow_failure": true,
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*wasm.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "manual"
}
],
@@ -4630,7 +4630,7 @@
"rules": [
{
"allow_failure": true,
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*wasm.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "manual"
}
],
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -56,6 +56,7 @@ data Signage = Signed | Unsigned deriving (Eq, Show)
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc (CmmProc infos lbl live graph) = do
let blocks = toBlockListEntryFirstFalseFallthrough graph
+
(lmblocks, lmdata) <- basicBlocksCodeGen live blocks
let info = mapLookup (g_entry graph) infos
proc = CmmProc info lbl live (ListGraph lmblocks)
@@ -67,6 +68,11 @@ genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
-- * Block code generation
--
+-- | Unreachable basic block
+--
+-- See Note [Unreachable block as default destination in Switch]
+newtype UnreachableBlockId = UnreachableBlockId BlockId
+
-- | Generate code for a list of blocks that make up a complete
-- procedure. The first block in the list is expected to be the entry
-- point.
@@ -82,20 +88,27 @@ basicBlocksCodeGen live cmmBlocks
(prologue, prologueTops) <- funPrologue live cmmBlocks
let entryBlock = BasicBlock bid (fromOL prologue)
+ -- allocate one unreachable basic block that can be used as a default
+ -- destination in exhaustive switches.
+ --
+ -- See Note [Unreachable block as default destination in Switch]
+ ubid@(UnreachableBlockId ubid') <- (UnreachableBlockId . mkBlockId) <$> getUniqueM
+ let ubblock = BasicBlock ubid' [Unreachable]
+
-- Generate code
- (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
+ (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks
-- Compose
- return (entryBlock : blocks, prologueTops ++ concat topss)
+ return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)
-- | Generate code for one block
-basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
-basicBlockCodeGen block
+basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen ubid block
= do let (_, nodes, tail) = blockSplit block
id = entryLabel block
- (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
- (tail_instrs, top') <- stmtToInstrs tail
+ (mid_instrs, top) <- stmtsToInstrs ubid $ blockToList nodes
+ (tail_instrs, top') <- stmtToInstrs ubid tail
let instrs = fromOL (mid_instrs `appOL` tail_instrs)
return (BasicBlock id instrs, top' ++ top)
@@ -110,15 +123,15 @@ type StmtData = (LlvmStatements, [LlvmCmmDecl])
-- | Convert a list of CmmNode's to LlvmStatement's
-stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
-stmtsToInstrs stmts
- = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
+stmtsToInstrs :: UnreachableBlockId -> [CmmNode e x] -> LlvmM StmtData
+stmtsToInstrs ubid stmts
+ = do (instrss, topss) <- fmap unzip $ mapM (stmtToInstrs ubid) stmts
return (concatOL instrss, concat topss)
-- | Convert a CmmStmt to a list of LlvmStatement's
-stmtToInstrs :: CmmNode e x -> LlvmM StmtData
-stmtToInstrs stmt = case stmt of
+stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData
+stmtToInstrs ubid stmt = case stmt of
CmmComment _ -> return (nilOL, []) -- nuke comments
CmmTick _ -> return (nilOL, [])
@@ -131,7 +144,7 @@ stmtToInstrs stmt = case stmt of
CmmBranch id -> genBranch id
CmmCondBranch arg true false likely
-> genCondBranch arg true false likely
- CmmSwitch arg ids -> genSwitch arg ids
+ CmmSwitch arg ids -> genSwitch ubid arg ids
-- Foreign Call
CmmUnsafeForeignCall target res args
@@ -1305,21 +1318,38 @@ For a real example of this, see ./rts/StgStdThunks.cmm
-- | Switch branch
-genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
-genSwitch cond ids = do
+genSwitch :: UnreachableBlockId -> CmmExpr -> SwitchTargets -> LlvmM StmtData
+genSwitch (UnreachableBlockId ubid) cond ids = do
(vc, stmts, top) <- exprToVar cond
let ty = getVarType vc
let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
| (ix, b) <- switchTargetsCases ids ]
- -- out of range is undefined, so let's just branch to first label
let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
- | otherwise = snd (head labels)
+ | otherwise = blockIdToLlvm ubid
+ -- switch to an unreachable basic block for exhaustive
+ -- switches. See Note [Unreachable block as default destination
+ -- in Switch]
let s1 = Switch vc defLbl labels
return $ (stmts `snocOL` s1, top)
+-- Note [Unreachable block as default destination in Switch]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- LLVM IR requires a default destination (a block label) for its Switch
+-- operation, even if the switch is exhaustive. An LLVM switch is considered
+-- exhausitve (e.g. to omit range checks for bit tests [1]) if the default
+-- destination is unreachable.
+--
+-- When we codegen a Cmm function, we always reserve an unreachable basic block
+-- that is used as a default destination for exhaustive Cmm switches in
+-- genSwitch. See #24717
+--
+-- [1] https://reviews.llvm.org/D68131
+
+
+
-- -----------------------------------------------------------------------------
-- * CmmExpr code generation
--
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1303,7 +1303,7 @@ ty_decl :: { LTyClDecl GhcPs }
| type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
- {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
+ {% mkTyData (comb5 $1 $3 $4 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
(snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6)
((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1244,7 +1244,7 @@ transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')
-- | Transfer comments from the annotations in the
-- first 'SrcSpanAnnA' argument to those in the second.
-transferCommentsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')
= (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs'))
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1220,19 +1220,23 @@ checkLPat e@(L l _) = checkPat l e [] []
checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
- | isRdrDataCon c = return . L loc $ ConPat
- { pat_con_ext = noAnn -- AZ: where should this come from?
- , pat_con = L ln c
- , pat_args = PrefixCon tyargs args
- }
+ | isRdrDataCon c = do
+ let (_l', loc') = transferCommentsOnlyA l loc
+ return . L loc' $ ConPat
+ { pat_con_ext = noAnn -- AZ: where should this come from?
+ , pat_con = L ln c
+ , pat_args = PrefixCon tyargs args
+ }
| (not (null args) && patIsRec c) = do
ctx <- askParseContext
patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
- checkPat loc f (HsConPatTyArg at t : tyargs) args
-checkPat loc (L _ (PatBuilderApp f e)) [] args = do
- p <- checkLPat e
- checkPat loc f [] (p : args)
+checkPat loc (L _ (PatBuilderAppType (L lf f) at t)) tyargs args = do
+ let (loc', lf') = transferCommentsOnlyA loc lf
+ checkPat loc' (L lf' f) (HsConPatTyArg at t : tyargs) args
+checkPat loc (L _ (PatBuilderApp f (L le e))) [] args = do
+ let (loc', le') = transferCommentsOnlyA loc le
+ p <- checkLPat (L le' e)
+ checkPat loc' f [] (p : args)
checkPat loc (L l e) [] [] = do
p <- checkAPat loc e
return (L l p)
@@ -1432,20 +1436,27 @@ isFunLhs e = go e [] [] []
where
mk = fmap ArgPatBuilderVisPat
- go (L _ (PatBuilderVar (L loc f))) es ops cps
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))
- go (L _ (PatBuilderApp f e)) es ops cps = go f (mk e:es) ops cps
- go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps = go e es (o:ops) (c:cps)
+ go (L l (PatBuilderVar (L loc f))) es ops cps
+ | not (isRdrDataCon f) = do
+ let (_l, loc') = transferCommentsOnlyA l loc
+ return (Just (L loc' f, Prefix, es, (reverse ops) ++ cps))
+ go (L l (PatBuilderApp (L lf f) e)) es ops cps = do
+ let (_l, lf') = transferCommentsOnlyA l lf
+ go (L lf' f) (mk e:es) ops cps
+ go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps)
-- NB: es@(_:_) means that there must be an arg after the parens for the
-- LHS to be a function LHS. This corresponds to the Haskell Report's definition
-- of funlhs.
where
+ (_l, le') = transferCommentsOnlyA l le
(o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- go (L loc (PatBuilderOpApp l (L loc' op) r anns)) es ops cps
+ go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r anns)) es ops cps
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (L loc' op, Infix, (mk l:mk r:es), (anns ++ reverse ops ++ cps)))
+ = do { let (_l, ll') = transferCommentsOnlyA loc ll
+ ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (anns ++ reverse ops ++ cps))) }
| otherwise -- Infix data con; keep going
- = do { mb_l <- go l es ops cps
+ = do { let (_l, ll') = transferCommentsOnlyA loc ll
+ ; mb_l <- go (L ll' l) es ops cps
; return (reassociate =<< mb_l) }
where
reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', anns')
@@ -1454,12 +1465,13 @@ isFunLhs e = go e [] [] []
op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
(L loc' op) r (reverse ops ++ cps))
reassociate _other = Nothing
- go (L _ (PatBuilderAppType pat tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
- = go pat (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
+ go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
+ = go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
where invis_pat = InvisPat tok ty_pat
anc' = case tok of
NoEpTok -> anc
EpTok l -> widenAnchor anc [AddEpAnn AnnAnyclass l]
+ (_l, lp') = transferCommentsOnlyA l lp
go _ _ _ _ = return Nothing
data ArgPatBuilder p
=====================================
docs/users_guide/bugs.rst
=====================================
@@ -445,15 +445,15 @@ In ``Prelude`` support
``Read``\ ing integers
GHC's implementation of the ``Read`` class for integral types
- accepts hexadecimal and octal literals (the code in the Haskell 98
+ accepts hexadecimal, octal and binary literals (the code in the Haskell 98
report doesn't). So, for example, ::
read "0xf00" :: Int
works in GHC.
- A possible reason for this is that ``readLitChar`` accepts hex and
- octal escapes, so it seems inconsistent not to do so for integers
+ This is to maintain consistency with the language's syntax. Haskell98
+ accepts hexadecimal and octal formats, and GHC2021 accepts binary formats
too.
``isAlpha``
=====================================
hadrian/src/Rules/Compile.hs
=====================================
@@ -218,6 +218,9 @@ compileHsObjectAndHi rs objpath = do
ctxPath <- contextPath ctx
(src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
need (src:deps)
+ -- The .conf file is needed when template-haskell is implicitly added as a dependency
+ -- when a module in the template-haskell package is compiled. (See #24737)
+ when (isLibrary (C.package ctx)) (need . (:[]) =<< pkgConfFile ctx)
-- The .dependencies file lists indicating inputs. ghc will
-- generally read more *.hi and *.hi-boot files (direct inputs).
=====================================
libraries/base/changelog.md
=====================================
@@ -3,6 +3,7 @@
## 4.21.0.0 *TBA*
* Add the `MonadFix` instance for `(,) a`, similar to the one for `Writer a` ([CLC proposal #238](https://github.com/haskell/core-libraries-committee/issues/238))
* Improve `toInteger :: Word32 -> Integer` on 64-bit platforms ([CLC proposal #259](https://github.com/haskell/core-libraries-committee/issues/259))
+ * Make `read` accept binary integer notation ([CLC proposal #177](https://github.com/haskell/core-libraries-committee/issues/177))
## 4.20.0.0 *TBA*
* Deprecate `GHC.Pack` ([#21461](https://gitlab.haskell.org/ghc/ghc/-/issues/21461))
=====================================
libraries/base/tests/char001.hs
=====================================
@@ -1,7 +1,8 @@
-- !!! Testing the behaviour of Char.lexLitChar a little..
--- [March 2003] We now allow \X and \O as escapes although the
--- spec only permits \x and \o. Seems more consistent.
+-- [March 2003] We now allow \X and \O as escapes although the
+-- spec only permits \x and \o. Seems more consistent.
+-- [January 2024] Binary character literals, something like '\b100' are not permitted.
module Main where
@@ -33,9 +34,15 @@ octs = do
lex' "'\\o14b'"
lex' "'\\0a4bg'"
+-- Binaries are NOT supported. '\b' stands for backspace.
+bins = do
+ lex' "'\\b'"
+ lex' "'\\b00'"
+
main = do
hexes
octs
+ bins
=====================================
libraries/base/tests/char001.stdout
=====================================
@@ -16,3 +16,5 @@ lex '\O000024' = [("'\\O000024'","")]
lex '\024b' = []
lex '\o14b' = []
lex '\0a4bg' = []
+lex '\b' = [("'\\b'","")]
+lex '\b00' = []
=====================================
libraries/base/tests/lex001.hs
=====================================
@@ -27,7 +27,23 @@ testStrings
"035e-3x",
"35e+3y",
"83.3e-22",
- "083.3e-22"
+ "083.3e-22",
+
+ "0b001",
+ "0b100",
+ "0b110",
+ "0B001",
+ "0B100",
+ "0B110",
+
+ "78_91",
+ "678_346",
+ "0x23d_fa4",
+ "0X23d_fa4",
+ "0o01_253",
+ "0O304_367",
+ "0b0101_0110",
+ "0B11_010_0110"
]
main = mapM test testStrings
=====================================
libraries/base/tests/lex001.stdout
=====================================
@@ -82,3 +82,58 @@
[("083.3e-22","")]
[(Number (MkDecimal [0,8,3] (Just [3]) (Just (-22))),"")]
+"0b001"
+[("0b001","")]
+[(Number (MkNumber 2 [0,0,1]),"")]
+
+"0b100"
+[("0b100","")]
+[(Number (MkNumber 2 [1,0,0]),"")]
+
+"0b110"
+[("0b110","")]
+[(Number (MkNumber 2 [1,1,0]),"")]
+
+"0B001"
+[("0B001","")]
+[(Number (MkNumber 2 [0,0,1]),"")]
+
+"0B100"
+[("0B100","")]
+[(Number (MkNumber 2 [1,0,0]),"")]
+
+"0B110"
+[("0B110","")]
+[(Number (MkNumber 2 [1,1,0]),"")]
+
+"78_91"
+[("78","_91")]
+[(Number (MkDecimal [7,8] Nothing Nothing),"_91")]
+
+"678_346"
+[("678","_346")]
+[(Number (MkDecimal [6,7,8] Nothing Nothing),"_346")]
+
+"0x23d_fa4"
+[("0x23d","_fa4")]
+[(Number (MkNumber 16 [2,3,13]),"_fa4")]
+
+"0X23d_fa4"
+[("0X23d","_fa4")]
+[(Number (MkNumber 16 [2,3,13]),"_fa4")]
+
+"0o01_253"
+[("0o01","_253")]
+[(Number (MkNumber 8 [0,1]),"_253")]
+
+"0O304_367"
+[("0O304","_367")]
+[(Number (MkNumber 8 [3,0,4]),"_367")]
+
+"0b0101_0110"
+[("0b0101","_0110")]
+[(Number (MkNumber 2 [0,1,0,1]),"_0110")]
+
+"0B11_010_0110"
+[("0B11","_010_0110")]
+[(Number (MkNumber 2 [1,1]),"_010_0110")]
=====================================
libraries/ghc-internal/src/GHC/Internal/Text/Read/Lex.hs
=====================================
@@ -300,6 +300,17 @@ lexCharE =
n <- lexInteger base
guard (n <= toInteger (ord maxBound))
return (chr (fromInteger n))
+ where
+ -- Slightly different variant of lexBaseChar that denies binary format.
+ -- Binary formats are not allowed for character/string literal.
+ lexBaseChar = do
+ c <- get
+ case c of
+ 'o' -> return 8
+ 'O' -> return 8
+ 'x' -> return 16
+ 'X' -> return 16
+ _ -> pfail
lexCntrlChar =
do _ <- char '^'
@@ -415,27 +426,28 @@ type Digits = [Int]
lexNumber :: ReadP Lexeme
lexNumber
- = lexHexOct <++ -- First try for hex or octal 0x, 0o etc
+ = lexHexOctBin <++ -- First try for hex, octal or binary 0x, 0o, 0b etc
-- If that fails, try for a decimal number
lexDecNumber -- Start with ordinary digits
-lexHexOct :: ReadP Lexeme
-lexHexOct
+lexHexOctBin :: ReadP Lexeme
+lexHexOctBin
= do _ <- char '0'
base <- lexBaseChar
digits <- lexDigits base
return (Number (MkNumber base digits))
-
-lexBaseChar :: ReadP Int
--- Lex a single character indicating the base; fail if not there
-lexBaseChar = do
- c <- get
- case c of
- 'o' -> return 8
- 'O' -> return 8
- 'x' -> return 16
- 'X' -> return 16
- _ -> pfail
+ where
+ -- Lex a single character indicating the base; fail if not there
+ lexBaseChar = do
+ c <- get
+ case c of
+ 'b' -> return 2
+ 'B' -> return 2
+ 'o' -> return 8
+ 'O' -> return 8
+ 'x' -> return 16
+ 'X' -> return 16
+ _ -> pfail
lexDecNumber :: ReadP Lexeme
lexDecNumber =
=====================================
testsuite/tests/printer/DataDeclShort.hs
=====================================
@@ -0,0 +1,8 @@
+module DataDeclShort where
+
+data GenericOptions
+ :: fieldLabelModifier
+ -> tagSingleConstructors
+ -> Type
+
+x = 1
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -831,3 +831,13 @@ PprLetIn:
CaseAltComments:
$(CHECK_PPR) $(LIBDIR) CaseAltComments.hs
$(CHECK_EXACT) $(LIBDIR) CaseAltComments.hs
+
+.PHONY: MatchPatComments
+MatchPatComments:
+ $(CHECK_PPR) $(LIBDIR) MatchPatComments.hs
+ $(CHECK_EXACT) $(LIBDIR) MatchPatComments.hs
+
+.PHONY: DataDeclShort
+DataDeclShort:
+ $(CHECK_PPR) $(LIBDIR) DataDeclShort.hs
+ $(CHECK_EXACT) $(LIBDIR) DataDeclShort.hs
=====================================
testsuite/tests/printer/MatchPatComments.hs
=====================================
@@ -0,0 +1,16 @@
+module MatchPatComments where
+
+expandProcess
+ outCHAs -- c0
+ locationDescr =
+ blah
+
+next
+ ( steps -- c1
+ , ys -- c2
+ ) x -- c3
+ = (steps, x, ys)
+
+makeProjection
+ Function{funMutual = VV, -- c4
+ funAbstr = ConcreteDef} = undefined
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -199,3 +199,5 @@ test('AnnotationNoListTuplePuns', [ignore_stderr, req_ppr_deps], makefile_test,
test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
test('CaseAltComments', [ignore_stderr, req_ppr_deps], makefile_test, ['CaseAltComments'])
+test('MatchPatComments', [ignore_stderr, req_ppr_deps], makefile_test, ['MatchPatComments'])
+test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])
=====================================
utils/check-exact/Main.hs
=====================================
@@ -128,7 +128,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr034.hs" Nothing
-- "../../testsuite/tests/printer/Ppr035.hs" Nothing
-- "../../testsuite/tests/printer/Ppr036.hs" Nothing
- "../../testsuite/tests/printer/Ppr037.hs" Nothing
+ "../../testsuite/tests/printer/MatchPatComments.hs" Nothing
-- "../../testsuite/tests/printer/Ppr038.hs" Nothing
-- "../../testsuite/tests/printer/Ppr039.hs" Nothing
-- "../../testsuite/tests/printer/Ppr040.hs" Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/424d88298893756dc3c18796e43807bfcb5e82a2...b62b36b4544b0c3a4266280285461aaf59b158e7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/424d88298893756dc3c18796e43807bfcb5e82a2...b62b36b4544b0c3a4266280285461aaf59b158e7
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/20240430/cd349ac4/attachment-0001.html>
More information about the ghc-commits
mailing list