[Git][ghc/ghc][wip/az/T24753-epa-mkhsoptypv-dup-comments] 5 commits: Fix parsing of module names in CLI arguments
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun May 5 16:57:15 UTC 2024
Alan Zimmerman pushed to branch wip/az/T24753-epa-mkhsoptypv-dup-comments at Glasgow Haskell Compiler / GHC
Commits:
af000532 by Moritz Schuler at 2024-05-05T06:30:58-04:00
Fix parsing of module names in CLI arguments
closes issue #24732
- - - - -
da74e9c9 by Ben Gamari at 2024-05-05T06:31:34-04:00
ghc-platform: Add Setup.hs
The Hadrian bootstrapping script relies upon `Setup.hs` to drive its
build.
Addresses #24761.
- - - - -
35d34fde by Alan Zimmerman at 2024-05-05T12:52:40-04:00
EPA: preserve comments in class and data decls
Fix checkTyClHdr which was discarding comments.
Closes #24755
- - - - -
03c5dfbf by Simon Peyton Jones at 2024-05-05T12:53:15-04:00
Fix a float-out error
Ticket #24768 showed that the Simplifier was accidentally destroying
a join point. It turned out to be that we were sending a bottoming
join point to the top, accidentally abstracting over /other/ join
points.
Easily fixed.
- - - - -
eb401582 by Alan Zimmerman at 2024-05-05T17:56:07+01:00
EPA: fix mkHsOpTyPV duplicating comments
Closes #24753
- - - - -
13 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/Language/Haskell/Syntax/Module/Name.hs
- + libraries/ghc-platform/Setup.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test24753.hs
- + testsuite/tests/printer/Test24755.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/rename/should_compile/T24732.hs
- + testsuite/tests/rename/should_compile/T24732.stdout
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/T24768.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1088,6 +1088,11 @@ But, as ever, we need to be careful:
as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
argument.
+ Do /not/ do this for bottoming /join-point/ bindings. They may call other
+ join points (#24768), and floating to the top would abstract over those join
+ points, which we should never do.
+
+
See Maessen's paper 1999 "Bottom extraction: factoring error handling out
of functional programs" (unpublished I think).
@@ -1252,9 +1257,11 @@ lvlBind env (AnnNonRec bndr rhs)
deann_rhs = deAnnotate rhs
mb_bot_str = exprBotStrictness_maybe deann_rhs
- is_bot_lam = isJust mb_bot_str
+ is_bot_lam = not is_join && isJust mb_bot_str
-- is_bot_lam: looks like (\xy. bot), maybe zero lams
- -- NB: not isBottomThunk! See Note [Bottoming floats] point (3)
+ -- NB: not isBottomThunk!
+ -- NB: not is_join: don't send bottoming join points to the top.
+ -- See Note [Bottoming floats] point (3)
is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty
n_extra = count isId abs_vars
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -204,11 +204,11 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl GhcPs)
mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
- = do { let loc = noAnnSrcSpan loc'
- ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
- ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
+ = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
+ ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr
; tyvars <- checkTyVars (text "class") whereDots cls tparams
; let anns' = annsIn Semi.<> ann
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
, tcdCtxt = mcxt
, tcdLName = cls, tcdTyVars = tyvars
@@ -231,12 +231,12 @@ mkTyData :: SrcSpan
-> P (LTyClDecl GhcPs)
mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons (L _ maybe_deriv) annsIn
- = do { let loc = noAnnSrcSpan loc'
- ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; let anns' = annsIn Semi.<> ann
- ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons
+ ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
; return (L loc (DataDecl { tcdDExt = anns',
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -263,14 +263,14 @@ mkTySynonym :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (text "type") equalsDots tc tparams
; let anns' = annsIn Semi.<> ann
- ; return (L (noAnnSrcSpan loc) (SynDecl
- { tcdSExt = anns'
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (SynDecl { tcdSExt = anns'
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
@@ -303,8 +303,9 @@ mkTyFamInstEqn :: SrcSpan
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn loc bndrs lhs rhs anns
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; return (L (noAnnSrcSpan loc) $ FamEqn
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' $ FamEqn
{ feqn_ext = anns `mappend` ann
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -324,10 +325,11 @@ mkDataFamInst :: SrcSpan
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons (L _ maybe_deriv) anns
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
- ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
(FamEqn { feqn_ext = ann Semi.<> anns
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -368,10 +370,10 @@ mkFamDecl :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl loc info topLevel lhs ksig injAnn annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
- ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
- (FamilyDecl
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (FamDecl noExtField (FamilyDecl
{ fdExt = annsIn Semi.<> ann
, fdTopLevel = topLevel
, fdInfo = info, fdLName = tc
@@ -1040,45 +1042,46 @@ checkTyClHdr :: Bool -- True <=> class header
-> P (LocatedN RdrName, -- the head symbol (type or class name)
[LHsTypeArg GhcPs], -- parameters of head symbol
LexicalFixity, -- the declaration is in infix format
- [AddEpAnn]) -- API Annotation for HsParTy
+ [AddEpAnn], -- API Annotation for HsParTy
-- when stripping parens
+ EpAnnComments) -- Accumulated comments from re-arranging
-- Well-formedness check and decomposition of type and class heads.
-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
-- Int :*: Bool into (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr is_cls ty
- = goL ty [] [] [] Prefix
+ = goL emptyComments ty [] [] [] Prefix
where
- goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
+ goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix
-- workaround to define '*' despite StarIsType
- go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
+ go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
= do { addPsMessage (locA l) PsWarnStarBinder
; let name = mkOccNameFS tcClsName (starSym isUni)
; let a' = newAnns ll l an
; return (L a' (Unqual name), acc, fix
- , (reverse ops') ++ cps') }
+ , (reverse ops') ++ cps', cs) }
- go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
- | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
- go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
- | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps)
+ go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
+ | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+ | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
where lhs = HsValArg noExtField t1
rhs = HsValArg noExtField t2
- go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
+ go cs l (HsParTy _ ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
where
(o,c) = mkParensEpAnn (realSrcSpan (locA l))
- go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix
- go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
- go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
+ go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix
+ go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix
+ go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
= return (L (l2l l) (nameRdrName tup_name)
- , map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
+ , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
- go l _ _ _ _ _
+ go _ l _ _ _ _ _
= addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrMalformedTyOrClDecl ty)
@@ -2056,7 +2059,10 @@ instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV = return
mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
- mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
+ mkHsOpTyPV prom t1 op t2 = do
+ let (L l ty) = mkLHsOpTy prom t1 op t2
+ !cs <- getCommentsFor (locA l)
+ return (L (addCommentsToEpAnn l cs) ty)
mkUnpackednessPV = addUnpackednessP
dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
@@ -2098,8 +2104,9 @@ instance DisambTD DataConBuilder where
mkHsOpTyPV prom lhs tc rhs = do
check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
data_con <- eitherToP $ tyConToDataCon tc
+ !cs <- getCommentsFor (locA l)
checkNotPromotedDataCon prom data_con
- return $ L l (InfixDataConBuilder lhs data_con rhs)
+ return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
where
l = combineLocsA lhs rhs
check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
@@ -3220,8 +3227,8 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy prom x op y =
- let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
- in L loc (mkHsOpTy prom x op y)
+ let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
+ in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs
mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr
=====================================
compiler/Language/Haskell/Syntax/Module/Name.hs
=====================================
@@ -56,5 +56,5 @@ moduleNameColons = dots_to_colons . moduleNameString
parseModuleName :: Parse.ReadP ModuleName
parseModuleName = fmap mkModuleName
- $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")
+ $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.'")
=====================================
libraries/ghc-platform/Setup.hs
=====================================
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -856,3 +856,13 @@ Test24749:
Test24754:
$(CHECK_PPR) $(LIBDIR) Test24754.hs
$(CHECK_EXACT) $(LIBDIR) Test24754.hs
+
+.PHONY: Test24755
+Test24755:
+ $(CHECK_PPR) $(LIBDIR) Test24755.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24755.hs
+
+.PHONY: Test24753
+Test24753:
+ $(CHECK_PPR) $(LIBDIR) Test24753.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24753.hs
=====================================
testsuite/tests/printer/Test24753.hs
=====================================
@@ -0,0 +1,8 @@
+module Test24753 where
+
+type ErrorChoiceApi
+ = "path0" :> Get '[JSON] Int -- c0
+ :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- c4
+ :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- c5
+ :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- c6
+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- c7
=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24755 where
+
+class
+ a -- Before operator
+ :+
+ b -- After operator
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -204,3 +204,5 @@ test('Test24748', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24748'])
test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])
test('Test24749', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24749'])
test('Test24754', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24754'])
+test('Test24755', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24755'])
+test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])
=====================================
testsuite/tests/rename/should_compile/T24732.hs
=====================================
@@ -0,0 +1,4 @@
+import P'
+
+main :: IO ()
+main = printf "Hello World\n"
\ No newline at end of file
=====================================
testsuite/tests/rename/should_compile/T24732.stdout
=====================================
@@ -0,0 +1 @@
+Hello World
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -223,3 +223,4 @@ test('T22478a', req_th, compile, [''])
test('RecordWildCardDeprecation', normal, multimod_compile, ['RecordWildCardDeprecation', '-Wno-duplicate-exports'])
test('T14032b', normal, compile_and_run, [''])
test('T14032d', normal, compile, [''])
+test('T24732', normal, compile_and_run, ['-package "base(Prelude, Text.Printf as P\')"'])
=====================================
testsuite/tests/simplCore/should_compile/T24768.hs
=====================================
@@ -0,0 +1,56 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- In this example the simplifer destroyed a join point,
+-- namely the `loop` inside `detectLeaks`
+
+module T24768 (detectLeaks) where
+
+import Control.Monad (zipWithM_)
+import Control.Monad.Reader (ReaderT(..))
+import Control.Monad.State (StateT, evalStateT)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+data Debuggee
+
+newtype DebugM a = DebugM (ReaderT Debuggee IO a)
+ deriving (Functor, Applicative, Monad)
+
+runSimple :: Debuggee -> DebugM a -> IO a
+runSimple d (DebugM a) = runReaderT a d
+
+cands :: [a]
+cands = []
+{-# NOINLINE cands #-}
+
+detectLeaks :: Debuggee -> IO ()
+detectLeaks e = loop M.empty
+ where
+ loop :: M.Map () RankInfo -> IO ()
+ loop rm = do
+ gs <- runSimple e $ mapM (findSlice rm) cands
+ zipWithM_ (\n _g -> writeFile
+ ("slices/" ++ show @Int n ++ ".dot")
+ "abcd")
+ [0..] gs
+ loop rm
+
+data RankInfo = RankInfo !Double !Int
+
+lookupRM :: () -> M.Map () RankInfo -> [((), RankInfo)]
+lookupRM k m = M.assocs filtered_map
+ where
+ (res_map, _) = M.partitionWithKey (\e _ -> e == k) m
+ filtered_map = M.filter (\(RankInfo r _) -> r > 0) res_map
+
+findSlice :: forall m a. Monad m => M.Map () RankInfo -> () -> m [a]
+findSlice rm _k = evalStateT go S.empty
+ where
+ go :: StateT s m [a]
+ go = do
+ let next_edges = lookupRM () rm
+ _ss <- concat <$> mapM (\_ -> go) next_edges
+ return []
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -515,3 +515,4 @@ test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
+test('T24768', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0367a1902a4092945e0dce74416cbdb96ac40e8f...eb4015828fe3f2a0e3f2c71afb96e3f6a02ea1db
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0367a1902a4092945e0dce74416cbdb96ac40e8f...eb4015828fe3f2a0e3f2c71afb96e3f6a02ea1db
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/20240505/c2a9c0f2/attachment-0001.html>
More information about the ghc-commits
mailing list