All the functions used in Paths modules are defined

The functions `splitFileNAme` and `minusFileName` are now defined in the same conditional block, ensuring that they cannot be used without being defined. This fix a bug occurring when generating a Paths_ module with --enable-relocatable.
haskell · Aug 5, 2022 · 6c79621 · 6c79621
1 parent 91a343f
commit 6c79621
Show file tree

Hide file tree

Showing 8 changed files with 106 additions and 47 deletions.
diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs b/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
@@ -104,6 +104,29 @@ render z_root = execWriter $ do
   tell "\n"
   tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"
   tell "\n"
+  let
+    z_var0_function_defs = do
+      tell "minusFileName :: FilePath -> String -> FilePath\n"
+      tell "minusFileName dir \"\"     = dir\n"
+      tell "minusFileName dir \".\"    = dir\n"
+      tell "minusFileName dir suffix =\n"
+      tell "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"
+      tell "\n"
+      tell "splitFileName :: FilePath -> (String, String)\n"
+      tell "splitFileName p = (reverse (path2++drive), reverse fname)\n"
+      tell "  where\n"
+      tell "    (path,drive) = case p of\n"
+      tell "      (c:':':p') -> (reverse p',[':',c])\n"
+      tell "      _          -> (reverse p ,\"\")\n"
+      tell "    (fname,path1) = break isPathSeparator path\n"
+      tell "    path2 = case path1 of\n"
+      tell "      []                           -> \".\"\n"
+      tell "      [_]                          -> path1   -- don't remove the trailing slash if\n"
+      tell "                                              -- there is only one character\n"
+      tell "      (c:path') | isPathSeparator c -> path'\n"
+      tell "      _                             -> path1\n"
+      return ()
+  tell "\n"
   tell "\n"
   if (zRelocatable z_root)
   then do
@@ -147,6 +170,8 @@ render z_root = execWriter $ do
     tell (zSysconfdir z_root)
     tell ")\n"
     tell "\n"
+    z_var0_function_defs
+    tell "\n"
     return ()
   else do
     if (zAbsolute z_root)
@@ -237,6 +262,8 @@ render z_root = execWriter $ do
         tell ") `joinFileName` dirRel)\n"
         tell "            | otherwise  -> try_size (size * 2)\n"
         tell "\n"
+        z_var0_function_defs
+        tell "\n"
         if (zIsI386 z_root)
         then do
           tell "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"
@@ -266,31 +293,6 @@ render z_root = execWriter $ do
     return ()
   tell "\n"
   tell "\n"
-  if (zNot z_root (zAbsolute z_root))
-  then do
-    tell "minusFileName :: FilePath -> String -> FilePath\n"
-    tell "minusFileName dir \"\"     = dir\n"
-    tell "minusFileName dir \".\"    = dir\n"
-    tell "minusFileName dir suffix =\n"
-    tell "  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"
-    tell "\n"
-    tell "splitFileName :: FilePath -> (String, String)\n"
-    tell "splitFileName p = (reverse (path2++drive), reverse fname)\n"
-    tell "  where\n"
-    tell "    (path,drive) = case p of\n"
-    tell "       (c:':':p') -> (reverse p',[':',c])\n"
-    tell "       _          -> (reverse p ,\"\")\n"
-    tell "    (fname,path1) = break isPathSeparator path\n"
-    tell "    path2 = case path1 of\n"
-    tell "      []                           -> \".\"\n"
-    tell "      [_]                          -> path1   -- don't remove the trailing slash if\n"
-    tell "                                              -- there is only one character\n"
-    tell "      (c:path') | isPathSeparator c -> path'\n"
-    tell "      _                             -> path1\n"
-    return ()
-  else do
-    return ()
-  tell "\n"
   tell "joinFileName :: String -> String -> FilePath\n"
   tell "joinFileName \"\"  fname = fname\n"
   tell "joinFileName \".\" fname = fname\n"

diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/Main.hs b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/Main.hs
@@ -0,0 +1,8 @@
+module Main where
+
+import Paths_PathsModule (getBinDir)
+
+main :: IO ()
+main = do
+    _ <- getBinDir
+    return ()
diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/my.cabal b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/my.cabal
@@ -0,0 +1,16 @@
+name: PathsModule
+version: 0.1
+license: BSD3
+author: Johan Tibell
+stability: stable
+category: PackageTests
+build-type: Simple
+Cabal-version: >= 1.2
+
+description:
+    Check that the generated paths module compiles.
+
+Executable TestPathsModule
+    main-is: Main.hs
+    other-modules: Paths_PathsModule
+    build-depends: base
diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.cabal.out b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.cabal.out
@@ -0,0 +1,5 @@
+# Setup configure
+Configuring PathsModule-0.1...
+# Setup build
+Preprocessing executable 'TestPathsModule' for PathsModule-0.1..
+Building executable 'TestPathsModule' for PathsModule-0.1..
diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.out b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.out
@@ -0,0 +1,5 @@
+# Setup configure
+Configuring PathsModule-0.1...
+# Setup build
+Preprocessing executable 'TestPathsModule' for PathsModule-0.1..
+Building executable 'TestPathsModule' for PathsModule-0.1..
diff --git a/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.test.hs b/cabal-testsuite/PackageTests/PathsModule/Executable-Relocatable/setup.test.hs
@@ -0,0 +1,7 @@
+import Test.Cabal.Prelude
+-- Test that Paths module is generated and usable when relocatable is turned on.
+
+main = setupAndCabalTest $ do
+  skipIfWindows
+  skipUnlessGhcVersion ">= 8.0"
+  setup_build ["--enable-relocatable"]
diff --git a/changelog.d/pr-8220 b/changelog.d/pr-8220
@@ -0,0 +1,12 @@
+synopsis: Fix generation of Path_ modules with relocatable
+packages: Cabal
+prs: #8220
+issues: #8219
+description: {
+
+The generation of the functions `minusFileName` and `splitFileName`
+are now in the same conditional block as their call,
+preventing generation of inconsistent Paths_ files
+where those functions are used but not defined.
+
+}
diff --git a/templates/Paths_pkg.template.hs b/templates/Paths_pkg.template.hs
@@ -58,6 +58,28 @@ getDataFileName name = do
 
 getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath
 
+{% defblock function_defs %}
+minusFileName :: FilePath -> String -> FilePath
+minusFileName dir ""     = dir
+minusFileName dir "."    = dir
+minusFileName dir suffix =
+  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))
+
+splitFileName :: FilePath -> (String, String)
+splitFileName p = (reverse (path2++drive), reverse fname)
+  where
+    (path,drive) = case p of
+      (c:':':p') -> (reverse p',[':',c])
+      _          -> (reverse p ,"")
+    (fname,path1) = break isPathSeparator path
+    path2 = case path1 of
+      []                           -> "."
+      [_]                          -> path1   -- don't remove the trailing slash if
+                                              -- there is only one character
+      (c:path') | isPathSeparator c -> path'
+      _                             -> path1
+{% endblock %}
+
 {# body #}
 {# ######################################################################### #}
 
@@ -76,6 +98,8 @@ getDataDir    = catchIO (getEnv "{{ manglePkgName packageName }}_datadir")    (\
 getLibexecDir = catchIO (getEnv "{{ manglePkgName packageName }}_libexecdir") (\_ -> getPrefixDirReloc $ {{ libexecdir }})
 getSysconfDir = catchIO (getEnv "{{ manglePkgName packageName }}_sysconfdir") (\_ -> getPrefixDirReloc $ {{ sysconfdir }})
 
+{% useblock function_defs %}
+
 {% elif absolute %}
 
 bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath
@@ -118,6 +142,8 @@ getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
               return ((bindir `minusFileName` {{ bindir}}) `joinFileName` dirRel)
             | otherwise  -> try_size (size * 2)
 
+{% useblock function_defs %}
+
 {% if isI386 %}
 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
   c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32
@@ -140,28 +166,6 @@ notRelocAbsoluteOrWindows = _
 {# filename stuff                                                            #}
 {# ######################################################################### #}
 
-{% if not absolute %}
-minusFileName :: FilePath -> String -> FilePath
-minusFileName dir ""     = dir
-minusFileName dir "."    = dir
-minusFileName dir suffix =
-  minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))
-
-splitFileName :: FilePath -> (String, String)
-splitFileName p = (reverse (path2++drive), reverse fname)
-  where
-    (path,drive) = case p of
-       (c:':':p') -> (reverse p',[':',c])
-       _          -> (reverse p ,"")
-    (fname,path1) = break isPathSeparator path
-    path2 = case path1 of
-      []                           -> "."
-      [_]                          -> path1   -- don't remove the trailing slash if
-                                              -- there is only one character
-      (c:path') | isPathSeparator c -> path'
-      _                             -> path1
-{% endif %}
-
 joinFileName :: String -> String -> FilePath
 joinFileName ""  fname = fname
 joinFileName "." fname = fname