Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
52 changes: 27 additions & 25 deletions Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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"
Expand Down Expand Up @@ -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"
Expand Down
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@
module Main where

import Paths_PathsModule (getBinDir)

main :: IO ()
main = do
_ <- getBinDir
return ()
Original file line number Diff line number Diff line change
@@ -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
Original file line number Diff line number Diff line change
@@ -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..
Original file line number Diff line number Diff line change
@@ -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..
Original file line number Diff line number Diff line change
@@ -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"]
12 changes: 12 additions & 0 deletions changelog.d/pr-8220
Original file line number Diff line number Diff line change
@@ -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.

}
48 changes: 26 additions & 22 deletions templates/Paths_pkg.template.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 #}
{# ######################################################################### #}

Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down