[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