[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Add Generic tuple instances up to 15-tuple
Marge Bot
gitlab at gitlab.haskell.org
Fri May 10 14:46:22 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
5d459cc5 by Oleg Grenrus at 2019-05-10T14:46:06Z
Add Generic tuple instances up to 15-tuple
Why 15? Because we have Eq instances up to 15.
Metric Increase:
T9630
haddock.base
- - - - -
12c7138b by Roland Senn at 2019-05-10T14:46:07Z
Fix bugs and documentation for #13456
- - - - -
67079e46 by David Eichmann at 2019-05-10T14:46:09Z
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.
- - - - -
cc4e9a52 by Ben Gamari at 2019-05-10T14:46:10Z
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]
- - - - -
15c151f8 by Kevin Buhr at 2019-05-10T14:46:10Z
Add regression test case for old issue #493
- - - - -
1f81e209 by Kevin Buhr at 2019-05-10T14:46:11Z
Add regression test for old parser issue #504
- - - - -
5d11276f by Oleg Grenrus at 2019-05-10T14:46:12Z
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.
- - - - -
9ba63649 by Vladislav Zavialov at 2019-05-10T14:46:13Z
Add a minimized regression test for #12928
- - - - -
5148d31f by Alp Mestanogullari at 2019-05-10T14:46:15Z
Hadrian: 'need' source files for various docs in Rules.Documentation
Previously, changing one of the .rst files from the user guide would not cause
the user guide to be rebuilt. This patch take a first stab at declaring the
documentation source files that our documentation rules depend on, focusing
on the .rst files only for now.
We eventually might want to rebuild docs when we, say, change the haddock style
file, but this level of tracking isn't really necessary for now.
This fixes #16645.
- - - - -
27 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/Documentation.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/Documentation.hs
=====================================
@@ -138,6 +138,9 @@ buildSphinxHtml path = do
root <- buildRootRules
root -/- htmlRoot -/- path -/- "index.html" %> \file -> do
let dest = takeDirectory file
+ rstFilesDir = pathPath path
+ rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
+ need (map (rstFilesDir -/-) rstFiles)
build $ target docContext (Sphinx Html) [pathPath path] [dest]
------------------------------------ Haddock -----------------------------------
@@ -242,6 +245,9 @@ buildSphinxPdf path = do
root <- buildRootRules
root -/- pdfRoot -/- path <.> "pdf" %> \file -> do
withTempDir $ \dir -> do
+ let rstFilesDir = pathPath path
+ rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
+ need (map (rstFilesDir -/-) rstFiles)
build $ target docContext (Sphinx Latex) [pathPath path] [dir]
build $ target docContext Xelatex [path <.> "tex"] [dir]
copyFileUntracked (dir -/- path <.> "pdf") file
=====================================
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/446278c713212fa91c09d66a6d2604779dbea546...5148d31fa2daefa2e25ed68b2b8681e63ab2ee16
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/446278c713212fa91c09d66a6d2604779dbea546...5148d31fa2daefa2e25ed68b2b8681e63ab2ee16
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/092191c7/attachment-0001.html>
More information about the ghc-commits
mailing list