[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Add Generic tuple instances up to 15-tuple
Marge Bot
gitlab at gitlab.haskell.org
Fri May 10 08:55:46 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
1f30b6b9 by Oleg Grenrus at 2019-05-10T08:55:31Z
Add Generic tuple instances up to 15-tuple
Why 15? Because we have Eq instances up to 15.
Metric Increase:
T9630
haddock.base
- - - - -
b68b98b2 by Roland Senn at 2019-05-10T08:55:32Z
Fix bugs and documentation for #13456
- - - - -
a44b9a7f by David Eichmann at 2019-05-10T08:55:34Z
Hadrian: programs need registered ghc-pkg libraries
In Hadrian, building programs (e.g. `ghc` or `haddock`) requires libraries located in the ghc-pkg package database i.e.
_build/stage1/lib/x86_64-linux-ghc-8.9.0.20190430/libHSdeepseq-1.4.4.0-ghc8.9.0.20190430.so
Add the corresponding `need`s for these library files and the subsequent rules.
- - - - -
cee1694e by Ben Gamari at 2019-05-10T08:55:34Z
gitlab-ci: Disable cleanup job on Windows
As discussed in the Note, we now have a cron job to handle this and the
cleanup job itself is quite fragile.
[skip ci]
- - - - -
f8d63976 by Kevin Buhr at 2019-05-10T08:55:35Z
Add regression test case for old issue #493
- - - - -
9850ef5b by Kevin Buhr at 2019-05-10T08:55:36Z
Add regression test for old parser issue #504
- - - - -
b1e3b618 by Oleg Grenrus at 2019-05-10T08:55:37Z
Update terminal title while running test-suite
Useful progress indicator even when `make test VERBOSE=1`,
and when you do something else, but have terminal title visible.
- - - - -
446278c7 by Vladislav Zavialov at 2019-05-10T08:55:37Z
Add a minimized regression test for #12928
- - - - -
26 changed files:
- .gitlab-ci.yml
- docs/users_guide/ghci.rst
- ghc/GHCi/UI.hs
- hadrian/src/Context.hs
- hadrian/src/Hadrian/BuildPath.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Program.hs
- hadrian/src/Rules/Rts.hs
- libraries/base/GHC/Generics.hs
- testsuite/.gitignore
- testsuite/driver/runtests.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- + testsuite/tests/ffi/should_run/T493.hs
- + testsuite/tests/ffi/should_run/T493.stdout
- + testsuite/tests/ffi/should_run/T493_c.c
- testsuite/tests/ffi/should_run/all.T
- testsuite/tests/ghci/scripts/T8113.script
- testsuite/tests/ghci/scripts/ghci005.stdout
- + testsuite/tests/ghci/should_run/T13456.script
- + testsuite/tests/ghci/should_run/T13456.stdout
- testsuite/tests/ghci/should_run/all.T
- + testsuite/tests/parser/should_compile/T504.hs
- testsuite/tests/parser/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T12928.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -19,7 +19,7 @@ stages:
- lint # Source linting
- build # A quick smoke-test to weed out broken commits
- full-build # Build all the things
- - cleanup # See Note [Cleanup on Windows]
+ - cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- hackage # head.hackage testing
- deploy # push documentation
@@ -673,35 +673,18 @@ nightly-i386-windows:
#
# As noted in [1], gitlab-runner's shell executor doesn't clean up its working
# directory after builds. Unfortunately, we are forced to use the shell executor
-# on Windows. To avoid running out of disk space we add a stage at the end of
-# the build to remove the \GitLabRunner\builds directory. Since we only run a
-# single build at a time on Windows this should be safe.
+# on Darwin. To avoid running out of disk space we add a stage at the end of
+# the build to remove the /.../GitLabRunner/builds directory. Since we only run a
+# single build at a time on Darwin this should be safe.
+#
+# We used to have a similar cleanup job on Windows as well however it ended up
+# being quite fragile as we have multiple Windows builders yet there is no
+# guarantee that the cleanup job is run on the same machine as the build itself
+# was run. Consequently we were forced to instead handle cleanup with a separate
+# cleanup cron job on Windows.
#
# [1] https://gitlab.com/gitlab-org/gitlab-runner/issues/3856
-# See Note [Cleanup after shell executor]
-cleanup-windows:
- <<: *only-default
- stage: cleanup
- tags:
- - x86_64-windows
- when: always
- dependencies: []
- before_script:
- - echo "Time to clean up"
- script:
- - echo "Let's go"
- after_script:
- - set "BUILD_DIR=%CI_PROJECT_DIR%"
- - set "BUILD_DIR=%BUILD_DIR:/=\%"
- - echo "Cleaning %BUILD_DIR%"
- - cd \GitLabRunner
- # This is way more complicated than it should be:
- # See https://stackoverflow.com/questions/1965787
- - del %BUILD_DIR%\* /F /Q
- - for /d %%p in (%BUILD_DIR%\*) do rd /Q /S "%%p"
- - exit /b 0
-
# See Note [Cleanup after shell executor]
cleanup-darwin:
<<: *only-default
=====================================
docs/users_guide/ghci.rst
=====================================
@@ -2366,7 +2366,10 @@ commonly used commands.
Typing ``:def`` on its own lists the currently-defined macros.
Attempting to redefine an existing command name results in an error
unless the ``:def!`` form is used, in which case the old command
- with that name is silently overwritten.
+ with that name is silently overwritten. However for builtin commands
+ the old command can still be used by preceeding the command name with
+ a double colon (eg ``::load``).
+ It's not possible to redefine the commands ``:{``, ``:}`` and ``:!``.
.. ghci-cmd:: :delete; * | ⟨num⟩ ...
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1618,8 +1618,11 @@ chooseEditFile =
-- :def
defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
-defineMacro _ (':':_) =
- liftIO $ putStrLn "macro name cannot start with a colon"
+defineMacro _ (':':_) = liftIO $ putStrLn
+ "macro name cannot start with a colon"
+defineMacro _ ('!':_) = liftIO $ putStrLn
+ "macro name cannot start with an exclamation mark"
+ -- little code duplication allows to grep error msg
defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
macros <- ghci_macros <$> getGHCiState
@@ -1629,33 +1632,38 @@ defineMacro overwrite s = do
then liftIO $ putStrLn "no macros defined"
else liftIO $ putStr ("the following macros are defined:\n" ++
unlines defined)
- else do
- if (not overwrite && macro_name `elem` defined)
- then throwGhcException (CmdLineError
- ("macro '" ++ macro_name ++ "' is already defined"))
- else do
-
- -- compile the expression
- handleSourceError GHC.printException $ do
- step <- getGhciStepIO
- expr <- GHC.parseExpr definition
- -- > ghciStepIO . definition :: String -> IO String
- let stringTy = nlHsTyVar stringTy_RDR
- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
- body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
- `mkHsApp` (nlHsPar expr)
- tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
- new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig
- hv <- GHC.compileParsedExprRemote new_expr
-
- let newCmd = Command { cmdName = macro_name
- , cmdAction = lift . runMacro hv
- , cmdHidden = False
- , cmdCompletionFunc = noCompletion
- }
-
- -- later defined macros have precedence
- modifyGHCiState $ \s ->
+ else do
+ isCommand <- isJust <$> lookupCommand' macro_name
+ let check_newname
+ | macro_name `elem` defined = throwGhcException (CmdLineError
+ ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))
+ | isCommand = throwGhcException (CmdLineError
+ ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))
+ | otherwise = return ()
+ hint = " Use ':def!' to overwrite."
+
+ unless overwrite check_newname
+ -- compile the expression
+ handleSourceError GHC.printException $ do
+ step <- getGhciStepIO
+ expr <- GHC.parseExpr definition
+ -- > ghciStepIO . definition :: String -> IO String
+ let stringTy = nlHsTyVar stringTy_RDR
+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
+ `mkHsApp` (nlHsPar expr)
+ tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
+ new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig
+ hv <- GHC.compileParsedExprRemote new_expr
+
+ let newCmd = Command { cmdName = macro_name
+ , cmdAction = lift . runMacro hv
+ , cmdHidden = False
+ , cmdCompletionFunc = noCompletion
+ }
+
+ -- later defined macros have precedence
+ modifyGHCiState $ \s ->
let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
in s { ghci_macros = newCmd : filtered }
=====================================
hadrian/src/Context.hs
=====================================
@@ -7,8 +7,8 @@ module Context (
-- * Paths
contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile,
- pkgHaddockFile, pkgLibraryFile, pkgGhciLibraryFile, pkgConfFile, objectPath,
- contextPath, getContextPath, libPath, distDir
+ pkgHaddockFile, pkgRegisteredLibraryFile, pkgLibraryFile, pkgGhciLibraryFile,
+ pkgConfFile, objectPath, contextPath, getContextPath, libPath, distDir
) where
import Base
@@ -59,11 +59,16 @@ distDir st = do
hostArch <- cabalArchString <$> setting BuildArch
return $ hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version
+pkgFileName :: Package -> String -> String -> Action FilePath
+pkgFileName package prefix suffix = do
+ pid <- pkgIdentifier package
+ return $ prefix ++ pid ++ suffix
+
pkgFile :: Context -> String -> String -> Action FilePath
pkgFile context at Context {..} prefix suffix = do
path <- buildPath context
- pid <- pkgIdentifier package
- return $ path -/- prefix ++ pid ++ suffix
+ fileName <- pkgFileName package prefix suffix
+ return $ path -/- fileName
-- | Path to inplace package configuration file of a given 'Context'.
pkgInplaceConfig :: Context -> Action FilePath
@@ -81,6 +86,20 @@ pkgHaddockFile Context {..} = do
let name = pkgName package
return $ root -/- "docs/html/libraries" -/- name -/- name <.> "haddock"
+-- | Path to the registered ghc-pkg library file of a given 'Context', e.g.:
+-- @_build/stage1/lib/x86_64-linux-ghc-8.9.0/libHSarray-0.5.1.0-ghc8.9.0.so@
+-- @_build/stage1/lib/x86_64-linux-ghc-8.9.0/array-0.5.1.0/libHSarray-0.5.4.0.a@
+pkgRegisteredLibraryFile :: Context -> Action FilePath
+pkgRegisteredLibraryFile context at Context {..} = do
+ libDir <- libPath context
+ pkgId <- pkgIdentifier package
+ extension <- libsuf stage way
+ fileName <- pkgFileName package "libHS" extension
+ distDir <- distDir stage
+ return $ if Dynamic `wayUnit` way
+ then libDir -/- distDir -/- fileName
+ else libDir -/- distDir -/- pkgId -/- fileName
+
-- | Path to the library file of a given 'Context', e.g.:
-- @_build/stage1/libraries/array/build/libHSarray-0.5.1.0.a at .
pkgLibraryFile :: Context -> Action FilePath
=====================================
hadrian/src/Hadrian/BuildPath.hs
=====================================
@@ -35,6 +35,40 @@ parseBuildPath root afterBuild = do
a <- afterBuild
return (BuildPath root stage pkgpath a)
+-- | A path of the form
+--
+-- > <build root>/stage<N>/lib/<arch>-<os>-ghc-<ghc version>/<something>
+--
+-- where @something@ describes a library or object file or ... to be registerd
+-- for the given package. These are files registered into a ghc-pkg database.
+--
+-- @a@, which represents that @something@, is instantiated with library-related
+-- data types in @Rules.Library@ and with object/interface files related types
+-- in @Rules.Compile at .
+data GhcPkgPath a
+ = GhcPkgPath
+ FilePath -- ^ > <build root>/
+ Stage -- ^ > stage<N>/
+ FilePath -- ^ > lib/<arch>-<os>-ghc-<ghc version>/
+ a -- ^ > whatever comes after
+ deriving (Eq, Show)
+
+-- | Parse a registered ghc-pkg path under the given build root.
+parseGhcPkgPath
+ :: FilePath -- ^ build root
+ -> Parsec.Parsec String () a -- ^ what to parse after @build/@
+ -> Parsec.Parsec String () (GhcPkgPath a)
+parseGhcPkgPath root after = do
+ _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+ stage <- parseStage
+ _ <- Parsec.char '/'
+ regPath <- Parsec.string "lib/"
+ <> Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/")
+ a <- after
+ return (GhcPkgPath root stage regPath a)
+
+
+
-- To be kept in sync with Stage.hs's stageString function
-- | Parse @"stageX"@ into a 'Stage'.
parseStage :: Parsec.Parsec String () Stage
=====================================
hadrian/src/Rules/Library.hs
=====================================
@@ -24,11 +24,27 @@ libraryRules = do
root -/- "//libHS*-*.so" %> buildDynamicLibUnix root "so"
root -/- "//*.a" %> buildStaticLib root
priority 2 $ do
- root -/- "//HS*-*.o" %> buildGhciLibO root
+ root -/- "stage*/lib//libHS*-*.dylib" %> registerDynamicLibUnix root "dylib"
+ root -/- "stage*/lib//libHS*-*.so" %> registerDynamicLibUnix root "so"
+ root -/- "stage*/lib//*.a" %> registerStaticLib root
+ root -/- "//HS*-*.o" %> buildGhciLibO root
root -/- "//HS*-*.p_o" %> buildGhciLibO root
-- * 'Action's for building libraries
+-- | Register (with ghc-pkg) a static library ('LibA') under the given build
+-- root, whose path is the second argument.
+registerStaticLib :: FilePath -> FilePath -> Action ()
+registerStaticLib root archivePath = do
+ -- Simply need the ghc-pkg database .conf file.
+ GhcPkgPath _ stage _ (LibA name version _)
+ <- parsePath (parseGhcPkgLibA root)
+ "<.a library (register) path parser>"
+ archivePath
+ need [ root -/- relativePackageDbPath stage
+ -/- (pkgId name version) ++ ".conf"
+ ]
+
-- | Build a static library ('LibA') under the given build root, whose path is
-- the second argument.
buildStaticLib :: FilePath -> FilePath -> Action ()
@@ -46,6 +62,21 @@ buildStaticLib root archivePath = do
(quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
archivePath synopsis
+-- | Register (with ghc-pkg) a dynamic library ('LibDyn') under the given build
+-- root, with the given suffix (@.so@ or @.dylib@, @.dll@ in the future), where
+-- the complete path of the registered dynamic library is given as the third
+-- argument.
+registerDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
+registerDynamicLibUnix root suffix dynlibpath = do
+ -- Simply need the ghc-pkg database .conf file.
+ (GhcPkgPath _ stage _ (LibDyn name version _ _))
+ <- parsePath (parseGhcPkgLibDyn root suffix)
+ "<dyn register lib parser>"
+ dynlibpath
+ need [ root -/- relativePackageDbPath stage
+ -/- pkgId name version ++ ".conf"
+ ]
+
-- | Build a dynamic library ('LibDyn') under the given build root, with the
-- given suffix (@.so@ or @.dylib@, @.dll@ in the future), where the complete
-- path of the archive to build is given as the third argument.
@@ -54,7 +85,7 @@ buildDynamicLibUnix root suffix dynlibpath = do
dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
let context = libDynContext dynlib
deps <- contextDependencies context
- need =<< mapM pkgLibraryFile deps
+ need =<< mapM pkgRegisteredLibraryFile deps
-- TODO should this be somewhere else?
-- Custom build step to generate libffi.so* in the rts build directory.
@@ -156,6 +187,16 @@ libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _)) =
where
pkg = library pkgname pkgpath
+-- | Parse a path to a registered ghc-pkg static library to be built, making
+-- sure the path starts with the given build root.
+parseGhcPkgLibA :: FilePath -> Parsec.Parsec String () (GhcPkgPath LibA)
+parseGhcPkgLibA root
+ = parseGhcPkgPath root
+ (do -- Skip past pkgId directory.
+ _ <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/")
+ parseLibAFilename)
+ Parsec.<?> "ghc-pkg path for a static library"
+
-- | Parse a path to a static library to be built, making sure the path starts
-- with the given build root.
parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
@@ -174,6 +215,12 @@ parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath Lib
parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext)
Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
+-- | Parse a path to a registered ghc-pkg dynamic library, making sure the path
+-- starts with the given package database root.
+parseGhcPkgLibDyn :: FilePath -> String -> Parsec.Parsec String () (GhcPkgPath LibDyn)
+parseGhcPkgLibDyn root ext = parseGhcPkgPath root (parseLibDynFilename ext)
+ Parsec.<?> ("ghc-pkg path for a dynamic library with extension " ++ ext)
+
-- | Parse the filename of a static library to be built into a 'LibA' value.
parseLibAFilename :: Parsec.Parsec String () LibA
parseLibAFilename = do
@@ -202,3 +249,7 @@ parseLibDynFilename ext = do
_ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
_ <- Parsec.string ("." ++ ext)
return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
+
+-- | Get the package identifier given the package name and version.
+pkgId :: String -> [Integer] -> String
+pkgId name version = name ++ "-" ++ intercalate "." (map show version)
\ No newline at end of file
=====================================
hadrian/src/Rules/Program.hs
=====================================
@@ -89,6 +89,15 @@ buildProgram bin ctx@(Context{..}) rs = do
-- Haddock has a resource folder
need =<< haddockDeps stage
+ -- Need library dependencies.
+ -- Note pkgLibraryFile gets the path in the build dir e.g.
+ -- _build/stage1/libraries/haskeline/build/libHShaskeline-0.7.5.0-ghc8.9.0.20190430.so
+ -- but when building the program, we link against the *ghc-pkg registered* library e.g.
+ -- _build/stage1/lib/x86_64-linux-ghc-8.9.0.20190430/libHShaskeline-0.7.5.0-ghc8.9.0.20190430.so
+ -- so we use pkgRegisteredLibraryFile instead.
+ need =<< mapM pkgRegisteredLibraryFile
+ =<< contextDependencies ctx
+
cross <- flag CrossCompiling
-- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
case (cross, stage) of
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -7,10 +7,10 @@ import Settings.Builders.Common
-- | Dynamic RTS library files need symlinks without the dummy version number.
-- This is for backwards compatibility (the old make build system omitted the
-- dummy version number).
--- This rule has priority 2 to override the general rule for generating share
+-- This rule has priority 3 to override the general rule for generating shared
-- library files (see Rules.Library.libraryRules).
rtsRules :: Rules ()
-rtsRules = priority 2 $ do
+rtsRules = priority 3 $ do
root <- buildRootRules
[ root -/- "//libHSrts_*-ghc*.so",
root -/- "//libHSrts_*-ghc*.dylib",
=====================================
libraries/base/GHC/Generics.hs
=====================================
@@ -1434,6 +1434,30 @@ deriving instance Generic ((,,,,,) a b c d e f)
-- | @since 4.6.0.0
deriving instance Generic ((,,,,,,) a b c d e f g)
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,) a b c d e f g h)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,) a b c d e f g h i)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n)
+
+-- | @since 4.14.0.0
+deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o)
+
-- | @since 4.12.0.0
deriving instance Generic (Down a)
@@ -1471,6 +1495,30 @@ deriving instance Generic1 ((,,,,,) a b c d e)
-- | @since 4.6.0.0
deriving instance Generic1 ((,,,,,,) a b c d e f)
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,) a b c d e f g)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,) a b c d e f g h)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m)
+
+-- | @since 4.14.0.0
+deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n)
+
-- | @since 4.12.0.0
deriving instance Generic1 Down
=====================================
testsuite/.gitignore
=====================================
@@ -694,6 +694,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
/tests/ffi/should_run/Capi_Ctype_002
/tests/ffi/should_run/Capi_Ctype_A_001.hs
/tests/ffi/should_run/Capi_Ctype_A_002.hs
+/tests/ffi/should_run/T493
/tests/ffi/should_run/T1288
/tests/ffi/should_run/T1679
/tests/ffi/should_run/T2276
=====================================
testsuite/driver/runtests.py
=====================================
@@ -189,6 +189,23 @@ else:
print('WARNING: No UTF8 locale found.')
print('You may get some spurious test failures.')
+# https://stackoverflow.com/a/22254892/1308058
+def supports_colors():
+ """
+ Returns True if the running system's terminal supports color, and False
+ otherwise.
+ """
+ plat = sys.platform
+ supported_platform = plat != 'Pocket PC' and (plat != 'win32' or
+ 'ANSICON' in os.environ)
+ # isatty is not always implemented, #6223.
+ is_a_tty = hasattr(sys.stdout, 'isatty') and sys.stdout.isatty()
+ if not supported_platform or not is_a_tty:
+ return False
+ return True
+
+config.supports_colors = supports_colors()
+
# This has to come after arg parsing as the args can change the compiler
get_compiler_info()
@@ -412,7 +429,7 @@ else:
print(Perf.allow_changes_string(t.metrics))
print('-' * 25)
- summary(t, sys.stdout, config.no_print_summary, True)
+ summary(t, sys.stdout, config.no_print_summary, config.supports_colors)
# Write perf stats if any exist or if a metrics file is specified.
stats = [stat for (_, stat) in t.metrics]
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -136,6 +136,9 @@ class TestConfig:
# The test environment.
self.test_env = 'local'
+ # terminal supports colors
+ self.supports_colors = False
+
global config
config = TestConfig()
=====================================
testsuite/driver/testlib.py
=====================================
@@ -891,11 +891,17 @@ def do_test(name, way, func, args, files):
full_name = name + '(' + way + ')'
- if_verbose(2, "=====> {0} {1} of {2} {3}".format(
- full_name, t.total_tests, len(allTestNames),
+ progress_args = [ full_name, t.total_tests, len(allTestNames),
[len(t.unexpected_passes),
len(t.unexpected_failures),
- len(t.framework_failures)]))
+ len(t.framework_failures)]]
+ if_verbose(2, "=====> {0} {1} of {2} {3}".format(*progress_args))
+
+ # Update terminal title
+ # useful progress indicator even when make test VERBOSE=1
+ if config.supports_colors:
+ print("\033]0;{0} {1} of {2} {3}\007".format(*progress_args), end="")
+ sys.stdout.flush()
# Clean up prior to the test, so that we can't spuriously conclude
# that it passed on the basis of old run outputs.
=====================================
testsuite/tests/ffi/should_run/T493.hs
=====================================
@@ -0,0 +1,41 @@
+import Foreign
+import Foreign.C
+
+-- These newtypes...
+newtype MyFunPtr a = MyFunPtr { getFunPtr :: FunPtr a }
+newtype MyPtr a = MyPtr (Ptr a)
+newtype MyIO a = MyIO { runIO :: IO a }
+-- should be supported by...
+
+-- foreign import dynamics
+foreign import ccall "dynamic"
+ mkFun1 :: MyFunPtr (CInt -> CInt) -> (CInt -> CInt)
+foreign import ccall "dynamic"
+ mkFun2 :: MyPtr (Int32 -> Int32) -> (CInt -> CInt)
+
+-- and foreign import wrappers.
+foreign import ccall "wrapper"
+ mkWrap1 :: (CInt -> CInt) -> MyIO (MyFunPtr (CInt -> CInt))
+foreign import ccall "wrapper"
+ mkWrap2 :: (CInt -> CInt) -> MyIO (MyPtr (Int32 -> Int32))
+
+-- We'll need a dynamic function point to export
+foreign import ccall "getDbl" getDbl :: IO (MyFunPtr (CInt -> CInt))
+-- and a Haskell function to export
+half :: CInt -> CInt
+half = (`div` 2)
+-- and a C function to pass it to.
+foreign import ccall "apply" apply1 :: MyFunPtr (CInt -> CInt) -> Int -> Int
+foreign import ccall "apply" apply2 :: MyPtr (Int32 -> Int32) -> Int -> Int
+
+main :: IO ()
+main = do
+
+ dbl <- getDbl
+ let dbl1 = mkFun1 dbl
+ dbl2 = mkFun2 $ MyPtr $ castFunPtrToPtr $ getFunPtr dbl
+ print (dbl1 21, dbl2 21)
+
+ half1 <- runIO $ mkWrap1 half
+ half2 <- runIO $ mkWrap2 half
+ print (apply1 half1 84, apply2 half2 84)
=====================================
testsuite/tests/ffi/should_run/T493.stdout
=====================================
@@ -0,0 +1,2 @@
+(42,42)
+(42,42)
=====================================
testsuite/tests/ffi/should_run/T493_c.c
=====================================
@@ -0,0 +1,16 @@
+typedef int (*intfun_p)(int);
+
+int dbl(int x)
+{
+ return x*2;
+}
+
+intfun_p getDbl(void)
+{
+ return dbl;
+}
+
+int apply(intfun_p f, int x)
+{
+ return f(x);
+}
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -198,3 +198,5 @@ test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c'
test('PrimFFIInt16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt16_c.c'])
test('PrimFFIWord16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord16_c.c'])
+
+test('T493', [], compile_and_run, ['T493_c.c'])
=====================================
testsuite/tests/ghci/scripts/T8113.script
=====================================
@@ -1,4 +1,4 @@
-:def type (\e -> putStrLn ("called :type for "++show e++" (ignoring)") >> return "")
+:def! type (\e -> putStrLn ("called :type for "++show e++" (ignoring)") >> return "")
:def
:t ()
:ty True
=====================================
testsuite/tests/ghci/scripts/ghci005.stdout
=====================================
@@ -3,7 +3,7 @@ the following macros are defined:
echo
hello, world!
hello, world!
-macro 'echo' is already defined
+macro 'echo' is already defined. Use ':def!' to overwrite.
HELLO, WORLD!
hello, world!
macro 'f' is not defined
=====================================
testsuite/tests/ghci/should_run/T13456.script
=====================================
@@ -0,0 +1,13 @@
+let macro _ = putStrLn "I'm a macro" >> return ""
+:def ! macro
+:def type macro
+:def ty macro
+:def! type macro
+:type macro
+:t macro
+::t macro
+::type macro
+:def test macro
+:def test macro
+:def! test macro
+:def
=====================================
testsuite/tests/ghci/should_run/T13456.stdout
=====================================
@@ -0,0 +1,11 @@
+macro name cannot start with an exclamation mark
+macro 'type' overwrites builtin command. Use ':def!' to overwrite.
+macro 'ty' overwrites builtin command. Use ':def!' to overwrite.
+I'm a macro
+I'm a macro
+macro :: p -> IO [Char]
+macro :: p -> IO [Char]
+macro 'test' is already defined. Use ':def!' to overwrite.
+the following macros are defined:
+test
+type
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -32,6 +32,7 @@ test('T12128', just_ghci, ghci_script, ['T12128.script'])
test('T12456', just_ghci, ghci_script, ['T12456.script'])
test('T12525', just_ghci, ghci_script, ['T12525.script'])
test('T12549', just_ghci, ghci_script, ['T12549.script'])
+test('T13456', [just_ghci, combined_output], ghci_script, ['T13456.script'])
test('BinaryArray', normal, compile_and_run, [''])
test('T14125a', just_ghci, ghci_script, ['T14125a.script'])
test('T13825-ghci',just_ghci, ghci_script, ['T13825-ghci.script'])
=====================================
testsuite/tests/parser/should_compile/T504.hs
=====================================
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
+module Bug where
+
+-- regression test for #504:
+-- the pragma start and end sequences can both start in column 1
+-- without parse error
+
+{-# RULES
+ "foo" foo 1 = 1
+#-}
+foo 1 = 1
=====================================
testsuite/tests/parser/should_compile/all.T
=====================================
@@ -143,3 +143,4 @@ test('T15675', normal, compile, [''])
test('T15781', normal, compile, [''])
test('T16339', normal, compile, [''])
test('T16619', [], multimod_compile, ['T16619', '-v0'])
+test('T504', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_compile/T12928.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds, PolyKinds #-}
+
+module T12928 where
+
+data P (a::k) = MkP
+
+data FffSym0 (l :: P a)
+
+-- Make sure that the kind of 'k' is not defaulted:
+--
+-- data FffSym0 (l :: P (a :: Type))
+--
+-- We expect kind polymorphism:
+--
+-- data FffSym0 (l :: P (a :: k))
+--
+type Inst (a :: P Either) (b :: P Maybe) = (FffSym0 a, FffSym0 b)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -673,3 +673,4 @@ test('T13951', normal, compile, [''])
test('T16411', normal, compile, [''])
test('T16609', normal, compile, [''])
test('T505', normal, compile, [''])
+test('T12928', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/ff790bad03d77bbf4714a7d26cf26cf337d84e31...446278c713212fa91c09d66a6d2604779dbea546
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/ff790bad03d77bbf4714a7d26cf26cf337d84e31...446278c713212fa91c09d66a6d2604779dbea546
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/20190510/9c31508d/attachment-0001.html>
More information about the ghc-commits
mailing list