1
+ {-# LANGUAGE DataKinds #-}
1
2
{-# LANGUAGE OverloadedStrings #-}
2
3
{-# LANGUAGE RankNTypes #-}
3
4
@@ -16,14 +17,17 @@ import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)
16
17
17
18
import Distribution.Client.Errors
18
19
import Distribution.Client.Utils (tryReadAddSourcePackageDesc )
19
- import Distribution.Package (Package (packageId ))
20
+ import Distribution.Package (Package (packageId ), packageName , unPackageName )
20
21
import Distribution.PackageDescription.Configuration (flattenPackageDescription )
21
22
import Distribution.Simple.PreProcess (knownSuffixHandlers )
22
- import Distribution.Simple.SrcDist (listPackageSourcesWithDie )
23
- import Distribution.Simple.Utils (dieWithException )
23
+ import Distribution.Simple.SrcDist (listPackageSources , listPackageSourcesWithDie )
24
+ import Distribution.Simple.Utils (dieWithException , tryFindPackageDesc )
24
25
import Distribution.Types.GenericPackageDescription (GenericPackageDescription )
25
26
import Distribution.Utils.Path
26
- ( getSymbolicPath
27
+ ( FileOrDir (File )
28
+ , Pkg
29
+ , SymbolicPath
30
+ , getSymbolicPath
27
31
, makeSymbolicPath
28
32
)
29
33
@@ -32,6 +36,7 @@ import qualified Codec.Archive.Tar.Entry as Tar
32
36
import qualified Codec.Compression.GZip as GZip
33
37
import qualified Data.ByteString as BS
34
38
import qualified Data.ByteString.Lazy as BSL
39
+ import qualified Data.Map.Strict as Map
35
40
import qualified Data.Set as Set
36
41
import System.Directory (canonicalizePath )
37
42
import System.FilePath
@@ -65,23 +70,45 @@ packageDirToSdist
65
70
-> IO BSL. ByteString
66
71
-- ^ resulting sdist tarball
67
72
packageDirToSdist verbosity gpd dir = do
68
- -- let thisDie :: Verbosity -> String -> IO a
69
- -- thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
70
- absDir <- canonicalizePath dir
71
- files' <- listPackageSourcesWithDie verbosity dieWithException (Just $ makeSymbolicPath absDir) (flattenPackageDescription gpd) knownSuffixHandlers
72
- let files :: [FilePath ]
73
- files = nub $ sort $ map (normalise . getSymbolicPath) files'
73
+ let prefix = prettyShow (packageId gpd)
74
+
75
+ mbWorkDir <- Just . makeSymbolicPath <$> canonicalizePath dir
76
+ cabalFilePath <-
77
+ getSymbolicPath
78
+ <$> tryFindPackageDesc verbosity mbWorkDir
79
+ files' <- listPackageSources verbosity mbWorkDir (flattenPackageDescription gpd) knownSuffixHandlers
80
+
81
+ let insertMapping
82
+ :: SymbolicPath Pkg File
83
+ -> Map FilePath FilePath
84
+ -> Map FilePath FilePath
85
+ insertMapping file =
86
+ let
87
+ value = normalise (getSymbolicPath file)
88
+
89
+ -- Replace the file name of the package description with one that
90
+ -- matches the actual package name.
91
+ -- See related issue #6299.
92
+ key =
93
+ prefix
94
+ </> if value == cabalFilePath
95
+ then unPackageName (packageName gpd) <.> " cabal"
96
+ else value
97
+ in
98
+ Map. insert key value
99
+
100
+ let files :: Map FilePath FilePath
101
+ files = foldr insertMapping Map. empty files'
74
102
75
103
let entriesM :: StateT (Set. Set FilePath ) (WriterT [Tar. Entry ] IO ) ()
76
104
entriesM = do
77
- let prefix = prettyShow (packageId gpd)
78
105
modify (Set. insert prefix)
79
106
case Tar. toTarPath True prefix of
80
107
Left err -> liftIO $ dieWithException verbosity $ ErrorPackingSdist err
81
108
Right path -> tell [Tar. directoryEntry path]
82
109
83
- for_ files $ \ file -> do
84
- let fileDir = takeDirectory (prefix </> file)
110
+ for_ ( Map. toAscList files) $ \ (tarFile, srcFile) -> do
111
+ let fileDir = takeDirectory tarFile
85
112
needsEntry <- gets (Set. notMember fileDir)
86
113
87
114
when needsEntry $ do
@@ -90,8 +117,8 @@ packageDirToSdist verbosity gpd dir = do
90
117
Left err -> liftIO $ dieWithException verbosity $ ErrorPackingSdist err
91
118
Right path -> tell [Tar. directoryEntry path]
92
119
93
- contents <- liftIO . fmap BSL. fromStrict . BS. readFile $ dir </> file
94
- case Tar. toTarPath False (prefix </> file) of
120
+ contents <- liftIO . fmap BSL. fromStrict . BS. readFile $ dir </> srcFile
121
+ case Tar. toTarPath False tarFile of
95
122
Left err -> liftIO $ dieWithException verbosity $ ErrorPackingSdist err
96
123
Right path -> tell [(Tar. fileEntry path contents){Tar. entryPermissions = Tar. ordinaryFilePermissions}]
97
124
0 commit comments