Make Setup.hs copy/install work when data-files uses **. (#6127)

quasicomputational · web-flow · commit 7fec503aa7b2 · 2019-07-03T16:56:14.000+01:00
Treating globs like filenames was always illegitimate, but this code was broken further by the addition of recursive globs. I had a look around for other dubious code along these lines, and it looks like this site is the only problematic one. Fixes #6125.
diff --git a/Cabal/ChangeLog.md b/Cabal/ChangeLog.md
@@ -34,6 +34,9 @@
   * Uniformly provide 'Semigroup' instances for `base < 4.9` via `semigroups` package
   * Setting `debug-info` now implies `library-stripping: False` and
     `executable-stripping: False) ([#2702](https://github.com/haskell/cabal/issues/2702))
+  * `Setup.hs copy` and `install` now work in the presence of
+    `data-files` that use `**` syntax
+    ([#6125](https://github.com/haskell/cabal/issues/6125)).
 
 ----
 
diff --git a/Cabal/Distribution/Simple/Install.hs b/Cabal/Distribution/Simple/Install.hs
@@ -223,17 +223,17 @@ copyComponent _ _ _ (CTest _) _ _ = return ()
 --
 installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()
 installDataFiles verbosity pkg_descr destDataDir =
-  flip traverse_ (dataFiles pkg_descr) $ \ file -> do
+  flip traverse_ (dataFiles pkg_descr) $ \ glob -> do
     let srcDataDirRaw = dataDir pkg_descr
         srcDataDir = if null srcDataDirRaw
           then "."
           else srcDataDirRaw
-    files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir file
-    let dir = takeDirectory file
-    createDirectoryIfMissingVerbose verbosity True (destDataDir </> dir)
-    sequence_ [ installOrdinaryFile verbosity (srcDataDir  </> file')
-                                              (destDataDir </> file')
-              | file' <- files ]
+    files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob
+    for_ files $ \ file' -> do
+      let src = srcDataDir </> file'
+          dst = destDataDir </> file'
+      createDirectoryIfMissingVerbose verbosity True (takeDirectory dst)
+      installOrdinaryFile verbosity src dst
 
 -- | Install the files listed in install-includes for a library
 --
diff --git a/cabal-testsuite/PackageTests/Regression/T6125/Main.hs b/cabal-testsuite/PackageTests/Regression/T6125/Main.hs
@@ -0,0 +1 @@
+main = return ()
diff --git a/cabal-testsuite/PackageTests/Regression/T6125/data/foo/bar.html b/cabal-testsuite/PackageTests/Regression/T6125/data/foo/bar.html
@@ -0,0 +1 @@
+<!DOCTYPE html>Some random data.
diff --git a/cabal-testsuite/PackageTests/Regression/T6125/myprog.cabal b/cabal-testsuite/PackageTests/Regression/T6125/myprog.cabal
@@ -0,0 +1,9 @@
+cabal-version: 2.4
+name: myprog
+version: 0
+data-files: data/**/*.html
+
+executable myprog
+  build-depends: base
+  main-is: Main.hs
+  default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/Regression/T6125/setup.cabal.out b/cabal-testsuite/PackageTests/Regression/T6125/setup.cabal.out
@@ -0,0 +1,9 @@
+# Setup configure
+Resolving dependencies...
+Configuring myprog-0...
+# Setup build
+Preprocessing executable 'myprog' for myprog-0..
+Building executable 'myprog' for myprog-0..
+# Setup copy
+Installing executable myprog in <PATH>
+Warning: The directory <ROOT>/setup.cabal.dist/usr/bin is not in the system search path.
diff --git a/cabal-testsuite/PackageTests/Regression/T6125/setup.out b/cabal-testsuite/PackageTests/Regression/T6125/setup.out
@@ -0,0 +1,8 @@
+# Setup configure
+Configuring myprog-0...
+# Setup build
+Preprocessing executable 'myprog' for myprog-0..
+Building executable 'myprog' for myprog-0..
+# Setup copy
+Installing executable myprog in <PATH>
+Warning: The directory <ROOT>/setup.dist/usr/bin is not in the system search path.
diff --git a/cabal-testsuite/PackageTests/Regression/T6125/setup.test.hs b/cabal-testsuite/PackageTests/Regression/T6125/setup.test.hs
@@ -0,0 +1,6 @@
+import Test.Cabal.Prelude
+main = setupAndCabalTest $ do
+    withPackageDb $ do
+        setup "configure" []
+        setup "build" ["myprog"]
+        setup "copy" ["myprog"]
