[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: packaging: Fix upload_ghc_libs.py script
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Dec 20 11:54:10 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
16102b11 by Matthew Pickering at 2022-12-20T06:53:55-05:00
packaging: Fix upload_ghc_libs.py script
This change reflects the changes where .cabal files are now generated by
hadrian rather than ./configure.
Fixes #22518
- - - - -
55653f2d by Ben Gamari at 2022-12-20T06:53:56-05:00
configure: Drop uses of AC_PROG_CC_C99
As noted in #22566, this macro is deprecated as of autoconf-2.70
`AC_PROG_CC` now sets `ac_cv_prog_cc_c99` itself.
Closes #22566.
- - - - -
48d634b2 by Ben Gamari at 2022-12-20T06:53:56-05:00
configure: Use AS_HELP_STRING instead of AC_HELP_STRING
The latter has been deprecated.
See #22566.
- - - - -
ea5fa6c2 by Bodigrim at 2022-12-20T06:53:57-05:00
GHCi.UI: fix various usages of head and tail
- - - - -
b4b9f6bd by Bodigrim at 2022-12-20T06:53:57-05:00
GHCi.UI: avoid head and tail in parseCallEscape and around
- - - - -
f1ca3dd1 by Bodigrim at 2022-12-20T06:53:57-05:00
Make GHC.Driver.Main.hscTcRnLookupRdrName to return NonEmpty
- - - - -
8 changed files:
- .gitlab/upload_ghc_libs.py
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- configure.ac
- distrib/configure.ac.in
- ghc/GHCi/UI.hs
- − m4/fp_set_cflags_c99.m4
Changes:
=====================================
.gitlab/upload_ghc_libs.py
=====================================
@@ -51,15 +51,19 @@ def prep_base():
def build_copy_file(pkg: Package, f: Path):
target = Path('_build') / 'stage1' / pkg.path / 'build' / f
dest = pkg.path / f
- print(f'Building {target} for {dest}...')
+ build_file_hadrian(target)
+ print(f'Copying {target} to {dest}...')
+ dest.parent.mkdir(exist_ok=True, parents=True)
+ shutil.copyfile(target, dest)
+
+def build_file_hadrian(target: Path):
build_cabal = Path('hadrian') / 'build-cabal'
if not build_cabal.is_file():
build_cabal = Path('hadrian') / 'build.cabal.sh'
+ print(f'Building {target}...')
run([build_cabal, target], check=True)
- dest.parent.mkdir(exist_ok=True, parents=True)
- shutil.copyfile(target, dest)
def modify_file(pkg: Package, fname: Path, f: Callable[[str], str]):
target = pkg.path / fname
@@ -116,6 +120,7 @@ def prepare_sdist(pkg: Package):
print(f'Preparing package {pkg.name}...')
shutil.rmtree(pkg.path / 'dist-newstyle', ignore_errors=True)
+ build_file_hadrian(pkg.path / '{}.cabal'.format(pkg.name))
pkg.prepare_sdist()
# Upload source tarball
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -266,6 +266,7 @@ import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
import Data.List ( nub, isPrefixOf, partition )
+import qualified Data.List.NonEmpty as NE
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
@@ -445,11 +446,15 @@ ioMsgMaybe' ioA = do
-- -----------------------------------------------------------------------------
-- | Lookup things in the compiler's environment
-hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
+hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
hscTcRnLookupRdrName hsc_env0 rdr_name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
- ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
+ -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.
+ -- Once errors has been dealt with in hoistTcRnMessage, we can enforce
+ -- this invariant in types by converting to NonEmpty.
+ ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $
+ tcRnLookupRdrName hsc_env rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
=====================================
compiler/GHC/Runtime/Debugger.hs
=====================================
@@ -49,6 +49,7 @@ import GHC.Types.TyThing
import Control.Monad
import Control.Monad.Catch as MC
import Data.List ( (\\), partition )
+import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.IORef
@@ -57,7 +58,7 @@ import Data.IORef
-------------------------------------
pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
pprintClosureCommand bindThings force str = do
- tythings <- (catMaybes . concat) `liftM`
+ tythings <- (catMaybes . concatMap NE.toList) `liftM`
mapM (\w -> GHC.parseName w >>=
mapM GHC.lookupName)
(words str)
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -121,6 +121,7 @@ import Data.Either
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
+import Data.List.NonEmpty (NonEmpty)
import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
@@ -903,7 +904,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do
-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
-parseName :: GhcMonad m => String -> m [Name]
+parseName :: GhcMonad m => String -> m (NonEmpty Name)
parseName str = withSession $ \hsc_env -> liftIO $
do { lrdr_name <- hscParseIdentifier hsc_env str
; hscTcRnLookupRdrName hsc_env lrdr_name }
=====================================
configure.ac
=====================================
@@ -143,7 +143,7 @@ if test "$EnableDistroToolchain" = "YES"; then
fi
AC_ARG_ENABLE(asserts-all-ways,
-[AC_HELP_STRING([--enable-asserts-all-ways],
+[AS_HELP_STRING([--enable-asserts-all-ways],
[Usually ASSERTs are only compiled in the DEBUG way,
this will enable them in all ways.])],
[FP_CAPITALIZE_YES_NO(["$enableval"], [EnableAssertsAllWays])],
@@ -485,11 +485,6 @@ FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs)
AC_SUBST([HaskellCPPCmd])
AC_SUBST([HaskellCPPArgs])
-FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS])
-FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
-
dnl ** Which ld to use
dnl --------------------------------------------------------------
AC_ARG_VAR(LD,[Use as the path to ld. See also --disable-ld-override.])
=====================================
distrib/configure.ac.in
=====================================
@@ -111,11 +111,6 @@ FP_CPP_CMD_WITH_ARGS(HaskellCPPCmd, HaskellCPPArgs)
AC_SUBST([HaskellCPPCmd])
AC_SUBST([HaskellCPPArgs])
-FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS])
-dnl FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1])
-FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
-
dnl ** Which ld to use?
dnl --------------------------------------------------------------
FIND_LD([$target],[GccUseLdOpt])
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -122,7 +122,7 @@ import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( elemIndices, find, intercalate, intersperse,
+import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
@@ -941,23 +941,26 @@ getInfoForPrompt = do
return (dots <> context_bit, modules_names, line)
-parseCallEscape :: String -> (String, String)
-parseCallEscape s
- | not (all isSpace beforeOpen) = ("", "")
- | null sinceOpen = ("", "")
- | null sinceClosed = ("", "")
- | null cmd = ("", "")
- | otherwise = (cmd, tail sinceClosed)
- where
- (beforeOpen, sinceOpen) = span (/='(') s
- (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
+-- | Takes a string, presumably following "%call", and tries to parse
+-- a command and arguments in parentheses:
+--
+-- > parseCallEscape " (cmd arg1 arg2)rest" = Just ("cmd" :| ["arg1", "arg2"], "rest")
+-- > parseCallEscape "( )rest" = Nothing
+--
+parseCallEscape :: String -> Maybe (NE.NonEmpty String, String)
+parseCallEscape s = case dropWhile isSpace s of
+ '(' : sinceOpen -> case span (/= ')') sinceOpen of
+ (call, ')' : sinceClosed)
+ | cmd : args <- words call -> Just (cmd NE.:| args, sinceClosed)
+ _ -> Nothing
+ _ -> Nothing
checkPromptStringForErrors :: String -> Maybe String
checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
case parseCallEscape xs of
- ("", "") -> Just ("Incorrect %call syntax. " ++
+ Nothing -> Just ("Incorrect %call syntax. " ++
"Should be %call(a command and arguments).")
- (_, afterClosed) -> checkPromptStringForErrors afterClosed
+ Just (_, afterClosed) -> checkPromptStringForErrors afterClosed
checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
checkPromptStringForErrors "" = Nothing
@@ -1010,10 +1013,12 @@ generatePromptFunctionFromString promptS modules_names line =
processString ('%':'V':xs) =
liftM ((text $ showVersion compilerVersion) <>) (processString xs)
processString ('%':'c':'a':'l':'l':xs) = do
+ -- Input has just been validated by parseCallEscape
+ let (cmd NE.:| args, afterClosed) = fromJust $ parseCallEscape xs
respond <- liftIO $ do
(code, out, err) <-
readProcessWithExitCode
- (head list_words) (tail list_words) ""
+ cmd args ""
`catchIO` \e -> return (ExitFailure 1, "", show e)
case code of
ExitSuccess -> return out
@@ -1021,9 +1026,6 @@ generatePromptFunctionFromString promptS modules_names line =
hPutStrLn stderr err
return ""
liftM ((text respond) <>) (processString afterClosed)
- where
- (cmd, afterClosed) = parseCallEscape xs
- list_words = words cmd
processString ('%':'%':xs) =
liftM ((char '%') <>) (processString xs)
processString (x:xs) =
@@ -1055,10 +1057,7 @@ installInteractivePrint :: GhciMonad m => Maybe String -> Bool -> m ()
installInteractivePrint Nothing _ = return ()
installInteractivePrint (Just ipFun) exprmode = do
ok <- trySuccess $ do
- names <- GHC.parseName ipFun
- let name = case names of
- name':_ -> name'
- [] -> panic "installInteractivePrint"
+ name NE.:| _ <- GHC.parseName ipFun
modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
in he{hsc_IC = new_ic})
return Succeeded
@@ -1374,12 +1373,13 @@ afterRunStmt step_here run_result = do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
GHC.ExecBreak names mb_info
- | isNothing mb_info ||
- step_here (GHC.resumeSpan $ head resumes) -> do
+ | first_resume : _ <- resumes
+ , isNothing mb_info ||
+ step_here (GHC.resumeSpan first_resume) -> do
mb_id_loc <- toBreakIdAndLocation mb_info
let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
if (null bCmd)
- then printStoppedAtBreakInfo (head resumes) names
+ then printStoppedAtBreakInfo first_resume names
else enqueueCommands [bCmd]
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
@@ -1596,7 +1596,7 @@ infoThing allInfo str = do
names <- GHC.parseName str
mb_stuffs <- mapM (GHC.getInfo allInfo) names
let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
- (catMaybes mb_stuffs)
+ (catMaybes (NE.toList mb_stuffs))
return $ vcat (intersperse (text "") $ map pprInfo filtered)
-- Filter out names whose parent is also there. Good
@@ -1917,7 +1917,7 @@ docCmd s = do
docs <- traverse (buildDocComponents s) names
- let sdocs = pprDocs docs
+ let sdocs = pprDocs (NE.toList docs)
sdocs' = vcat (intersperse (text "") sdocs)
sdoc <- showSDocForUser' sdocs'
liftIO (putStrLn sdoc)
@@ -2607,15 +2607,14 @@ guessCurrentModule :: GHC.GhcMonad m => String -> m Module
-- Guess which module the user wants to browse. Pick
-- modules that are interpreted first. The most
-- recently-added module occurs last, it seems.
-guessCurrentModule cmd
- = do imports <- GHC.getContext
- when (null imports) $ throwGhcException $
- CmdLineError (':' : cmd ++ ": no current module")
- case (head imports) of
- IIModule m -> GHC.findQualifiedModule NoPkgQual m
- IIDecl d -> do
- pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
- GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
+guessCurrentModule cmd = do
+ imports <- GHC.getContext
+ case imports of
+ [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
+ IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
+ IIDecl d : _ -> do
+ pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
+ GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
-- without bang, show items in context of their parents and omit children
-- with bang, show class methods and data constructors separately, and
@@ -3507,18 +3506,15 @@ completeCmd argLine0 = case parseLine argLine0 of
liftIO $ print r
_ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
where
- parseLine argLine
- | null argLine = Nothing
- | null rest1 = Nothing
- | otherwise = (,,) dom <$> resRange <*> s
- where
- (dom, rest1) = breakSpace argLine
- (rng, rest2) = breakSpace rest1
- resRange | head rest1 == '"' = parseRange ""
- | otherwise = parseRange rng
- s | head rest1 == '"' = readMaybe rest1 :: Maybe String
- | otherwise = readMaybe rest2
- breakSpace = fmap (dropWhile isSpace) . break isSpace
+ parseLine [] = Nothing
+ parseLine argLine = case breakSpace argLine of
+ (_, []) -> Nothing
+ (dom, rest1@('"' : _)) -> (dom,,) <$> parseRange "" <*> (readMaybe rest1 :: Maybe String)
+ (dom, rest1) -> (dom,,) <$> parseRange rng <*> readMaybe rest2
+ where
+ (rng, rest2) = breakSpace rest1
+
+ breakSpace = fmap (dropWhile isSpace) . break isSpace
takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
@@ -3658,7 +3654,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
createInscope :: GhciMonad m => String -> m [(String, Module)]
createInscope str_rdr = do
names <- GHC.parseName str_rdr
- pure $ zip (repeat str_rdr) $ GHC.nameModule <$> names
+ pure $ map (str_rdr, ) $ NE.toList $ GHC.nameModule <$> names
-- For every top-level identifier in scope, add the bids of the nested
-- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types
@@ -3666,7 +3662,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
addNestedDecls (ident, mod) = do
(_, decls) <- getModBreak mod
let (mod_str, topLvl, _) = splitIdent ident
- ident_decls = filter ((topLvl ==) . head) $ elems decls
+ ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]
bids = nub $ declPath <$> ident_decls
pure $ map (combineModIdent mod_str) bids
@@ -3843,7 +3839,7 @@ enclosingTickSpan md (RealSrcSpan src _) = do
massert (inRange (bounds ticks) line)
let enclosing_spans = [ pan | (_,pan) <- ticks ! line
, realSrcSpanEnd pan >= realSrcSpanEnd src]
- return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+ return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans
where
leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
@@ -4110,9 +4106,7 @@ breakById inp = do
lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)
lookupModuleInscope mod_top_lvl = do
names <- GHC.parseName mod_top_lvl
- pure $ Just $ head $ GHC.nameModule <$> names
- -- if GHC.parseName succeeds `names` is not empty!
- -- if it fails, the last line will not be evaluated.
+ pure $ Just $ NE.head $ GHC.nameModule <$> names
-- Lookup the Module of a module name in the module graph
lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)
@@ -4645,20 +4639,17 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m
-> m ()
wantNameFromInterpretedModule noCanDo str and_then =
handleSourceError GHC.printException $ do
- names <- GHC.parseName str
- case names of
- [] -> return ()
- (n:_) -> do
- let modl = assert (isExternalName n) $ GHC.nameModule n
- if not (GHC.isExternalName n)
- then noCanDo n $ ppr n <>
- text " is not defined in an interpreted module"
- else do
- is_interpreted <- GHC.moduleIsInterpreted modl
- if not is_interpreted
- then noCanDo n $ text "module " <> ppr modl <>
- text " is not interpreted"
- else and_then n
+ n NE.:| _ <- GHC.parseName str
+ let modl = assert (isExternalName n) $ GHC.nameModule n
+ if not (GHC.isExternalName n)
+ then noCanDo n $ ppr n <>
+ text " is not defined in an interpreted module"
+ else do
+ is_interpreted <- GHC.moduleIsInterpreted modl
+ if not is_interpreted
+ then noCanDo n $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else and_then n
clearCaches :: GhciMonad m => m ()
clearCaches = discardActiveBreakPoints
=====================================
m4/fp_set_cflags_c99.m4 deleted
=====================================
@@ -1,38 +0,0 @@
-# FP_SET_CFLAGS_C99
-# ----------------------------------
-# figure out which CFLAGS are needed to place the compiler into C99 mode
-# $1 is name of CC variable (unmodified)
-# $2 is name of CC flags variable (augmented if needed)
-# $3 is name of CPP flags variable (augmented if needed)
-AC_DEFUN([FP_SET_CFLAGS_C99],
-[
- dnl save current state of AC_PROG_CC_C99
- FP_COPY_SHELLVAR([CC],[fp_save_CC])
- FP_COPY_SHELLVAR([CFLAGS],[fp_save_CFLAGS])
- FP_COPY_SHELLVAR([CPPFLAGS],[fp_save_CPPFLAGS])
- FP_COPY_SHELLVAR([ac_cv_prog_cc_c99],[fp_save_cc_c99])
- dnl set local state
- CC="$$1"
- CFLAGS="$$2"
- CPPFLAGS="$$3"
- unset ac_cv_prog_cc_c99
- dnl perform detection
- AC_PROG_CC_C99
- fp_cc_c99="$ac_cv_prog_cc_c99"
- case "x$ac_cv_prog_cc_c99" in
- x) ;; # noop
- xno) AC_MSG_ERROR([C99-compatible compiler needed]) ;;
- *) $2="$$2 $ac_cv_prog_cc_c99"
- $3="$$3 $ac_cv_prog_cc_c99"
- ;;
- esac
- dnl restore saved state
- FP_COPY_SHELLVAR([fp_save_CC],[CC])
- FP_COPY_SHELLVAR([fp_save_CFLAGS],[CFLAGS])
- FP_COPY_SHELLVAR([fp_save_CPPFLAGS],[CPPFLAGS])
- FP_COPY_SHELLVAR([fp_save_cc_c99],[ac_cv_prog_cc_c99])
- dnl cleanup
- unset fp_save_CC
- unset fp_save_CFLAGS
- unset fp_save_cc_c99
-])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/756ebb70c67868e8286f75fe18b31c455afd25e2...f1ca3dd1aafbdd6e7ac68da679473870d97a54e6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/756ebb70c67868e8286f75fe18b31c455afd25e2...f1ca3dd1aafbdd6e7ac68da679473870d97a54e6
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/20221220/53869344/attachment-0001.html>
More information about the ghc-commits
mailing list