-
Notifications
You must be signed in to change notification settings - Fork 683
/
SrcDist.hs
592 lines (554 loc) · 20.7 KB
/
SrcDist.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- NOTE: FIX: we don't have a great way of testing this module, since
-- we can't easily look inside a tarball once its created.
-- |
-- Module : Distribution.Simple.SrcDist
-- Copyright : Simon Marlow 2004
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This handles the @sdist@ command. The module exports an 'sdist' action but
-- also some of the phases that make it up so that other tools can use just the
-- bits they need. In particular the preparation of the tree of files to go
-- into the source tarball is separated from actually building the source
-- tarball.
--
-- The 'createArchive' action uses the external @tar@ program and assumes that
-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows.
-- The 'sdist' action now also does some distribution QA checks.
module Distribution.Simple.SrcDist
( -- * The top level action
sdist
-- ** Parts of 'sdist'
, printPackageProblems
, prepareTree
, createArchive
-- ** Snapshots
, prepareSnapshotTree
, snapshotPackage
, snapshotVersion
, dateToSnapshotNumber
-- * Extracting the source files
, listPackageSources
, listPackageSourcesWithDie
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.ModuleName
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Check hiding (doesFileExist)
import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Configure (findDistPrefOrDefault)
import Distribution.Simple.Flag
import Distribution.Simple.Glob
import Distribution.Simple.PreProcess
import Distribution.Simple.Program
import Distribution.Simple.Setup.SDist
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
import qualified Data.Map as Map
import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
import Distribution.Simple.Errors
import System.Directory (doesFileExist)
import System.FilePath (dropExtension, isRelative, (<.>), (</>))
import System.IO (IOMode (WriteMode), hPutStrLn, withFile)
-- | Create a source distribution.
sdist
:: PackageDescription
-- ^ information from the tarball
-> SDistFlags
-- ^ verbosity & snapshot
-> (FilePath -> FilePath)
-- ^ build prefix (temp dir)
-> [PPSuffixHandler]
-- ^ extra preprocessors (includes suffixes)
-> IO ()
sdist pkg flags mkTmpDir pps = do
distPref <- findDistPrefOrDefault $ sDistDistPref flags
let targetPref = distPref
tmpTargetDir = mkTmpDir distPref
-- When given --list-sources, just output the list of sources to a file.
case sDistListSources flags of
Flag path -> withFile path WriteMode $ \outHandle -> do
ordinary <- listPackageSources verbosity "." pkg pps
traverse_ (hPutStrLn outHandle) ordinary
notice verbosity $ "List of package sources written to file '" ++ path ++ "'"
NoFlag -> do
-- do some QA
printPackageProblems verbosity pkg
date <- getCurrentTime
let pkg'
| snapshot = snapshotPackage date pkg
| otherwise = pkg
case flagToMaybe (sDistDirectory flags) of
Just targetDir -> do
generateSourceDir targetDir pkg'
info verbosity $ "Source directory created: " ++ targetDir
Nothing -> do
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
let targetDir = tmpDir </> tarBallName pkg'
generateSourceDir targetDir pkg'
targzFile <- createArchive verbosity pkg' tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile
where
generateSourceDir :: FilePath -> PackageDescription -> IO ()
generateSourceDir targetDir pkg' = do
setupMessage verbosity "Building source dist for" (packageId pkg')
prepareTree verbosity pkg' targetDir pps
when snapshot $
overwriteSnapshotPackageDesc verbosity pkg' targetDir
verbosity = fromFlag (sDistVerbosity flags)
snapshot = fromFlag (sDistSnapshot flags)
-- | List all source files of a package.
--
-- Since @Cabal-3.4@ returns a single list. There shouldn't be any
-- executable files, they are hardly portable.
listPackageSources
:: Verbosity
-- ^ verbosity
-> FilePath
-- ^ directory with cabal file
-> PackageDescription
-- ^ info from the cabal file
-> [PPSuffixHandler]
-- ^ extra preprocessors (include suffixes)
-> IO [FilePath]
-- ^ relative paths
listPackageSources verbosity cwd pkg_descr0 pps = do
-- Call helpers that actually do all work.
listPackageSources' verbosity dieWithException cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
-- | A variant of 'listPackageSources' with configurable 'die'.
--
-- /Note:/ may still 'die' directly. For example on missing include file.
--
-- Since @3.4.0.0
listPackageSourcesWithDie
:: Verbosity
-- ^ verbosity
-> (Verbosity -> CabalException -> IO [FilePath])
-- ^ 'die'' alternative.
-- Since 'die'' prefixes the error message with 'errorPrefix',
-- whatever is passed in here and wants to die should do the same.
-- See issue #7331.
-> FilePath
-- ^ directory with cabal file
-> PackageDescription
-- ^ info from the cabal file
-> [PPSuffixHandler]
-- ^ extra preprocessors (include suffixes)
-> IO [FilePath]
-- ^ relative paths
listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do
-- Call helpers that actually do all work.
listPackageSources' verbosity rip cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
listPackageSources'
:: Verbosity
-- ^ verbosity
-> (Verbosity -> CabalException -> IO [FilePath])
-- ^ 'die'' alternative.
-- Since 'die'' prefixes the error message with 'errorPrefix',
-- whatever is passed in here and wants to die should do the same.
-- See issue #7331.
-> FilePath
-- ^ directory with cabal file
-> PackageDescription
-- ^ info from the cabal file
-> [PPSuffixHandler]
-- ^ extra preprocessors (include suffixes)
-> IO [FilePath]
-- ^ relative paths
listPackageSources' verbosity rip cwd pkg_descr pps =
fmap concat . sequenceA $
[ -- Library sources.
fmap concat
. withAllLib
$ \Library
{ exposedModules = modules
, signatures = sigs
, libBuildInfo = libBi
} ->
allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)
, -- Executables sources.
fmap concat
. withAllExe
$ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps []
mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath
return (mainSrc : biSrcs)
, -- Foreign library sources
fmap concat
. withAllFLib
$ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []
defFiles <-
traverse
(findModDefFile verbosity cwd flibBi pps)
(foreignLibModDefFile flib)
return (defFiles ++ biSrcs)
, -- Test suites sources.
fmap concat
. withAllTest
$ \t -> do
let bi = testBuildInfo t
case testInterface t of
TestSuiteExeV10 _ mainPath -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
return (srcMainFile : biSrcs)
TestSuiteLibV09 _ m ->
allSourcesBuildInfo verbosity rip cwd bi pps [m]
TestSuiteUnsupported tp ->
rip verbosity $ UnsupportedTestSuite (show tp)
, -- Benchmarks sources.
fmap concat
. withAllBenchmark
$ \bm -> do
let bi = benchmarkBuildInfo bm
case benchmarkInterface bm of
BenchmarkExeV10 _ mainPath -> do
biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
return (srcMainFile : biSrcs)
BenchmarkUnsupported tp ->
rip verbosity $ UnsupportedBenchMark (show tp)
, -- Data files.
fmap concat
. for (dataFiles pkg_descr)
$ \filename ->
do
let srcDataDirRaw = dataDir pkg_descr
srcDataDir
| null srcDataDirRaw = "."
| otherwise = srcDataDirRaw
matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
, -- Extra source files.
fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath
, -- Extra doc files.
fmap concat
. for (extraDocFiles pkg_descr)
$ \filename ->
matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename
, -- License file(s).
return (map getSymbolicPath $ licenseFiles pkg_descr)
, -- Install-include files, without autogen-include files
fmap concat
. withAllLib
$ \l -> do
let lbi = libBuildInfo l
incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)
relincdirs = "." : filter isRelative (includeDirs lbi)
traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls
, -- Setup script, if it exists.
fmap (maybe [] (\f -> [f])) $ findSetupFile cwd
, -- The .cabal file itself.
fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")
]
where
-- We have to deal with all libs and executables, so we have local
-- versions of these functions that ignore the 'buildable' attribute:
withAllLib action = traverse action (allLibraries pkg_descr)
withAllFLib action = traverse action (foreignLibs pkg_descr)
withAllExe action = traverse action (executables pkg_descr)
withAllTest action = traverse action (testSuites pkg_descr)
withAllBenchmark action = traverse action (benchmarks pkg_descr)
-- | Prepare a directory tree of source files.
prepareTree
:: Verbosity
-- ^ verbosity
-> PackageDescription
-- ^ info from the cabal file
-> FilePath
-- ^ source tree to populate
-> [PPSuffixHandler]
-- ^ extra preprocessors (includes suffixes)
-> IO ()
prepareTree verbosity pkg_descr0 targetDir pps = do
ordinary <- listPackageSources verbosity "." pkg_descr pps
installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
maybeCreateDefaultSetupScript targetDir
where
pkg_descr = filterAutogenModules pkg_descr0
-- | Find the setup script file, if it exists.
findSetupFile :: FilePath -> IO (Maybe FilePath)
findSetupFile targetDir = do
hsExists <- doesFileExist (targetDir </> setupHs)
lhsExists <- doesFileExist (targetDir </> setupLhs)
if hsExists
then return (Just setupHs)
else
if lhsExists
then return (Just setupLhs)
else return Nothing
where
setupHs = "Setup.hs"
setupLhs = "Setup.lhs"
-- | Create a default setup script in the target directory, if it doesn't exist.
maybeCreateDefaultSetupScript :: FilePath -> IO ()
maybeCreateDefaultSetupScript targetDir = do
mSetupFile <- findSetupFile targetDir
case mSetupFile of
Just _setupFile -> return ()
Nothing -> do
writeUTF8File (targetDir </> "Setup.hs") $
unlines
[ "import Distribution.Simple"
, "main = defaultMain"
]
-- | Find the main executable file.
findMainExeFile
:: Verbosity
-> FilePath
-- ^ cwd
-> BuildInfo
-> [PPSuffixHandler]
-> FilePath
-- ^ main-is
-> IO FilePath
findMainExeFile verbosity cwd exeBi pps mainPath = do
ppFile <-
findFileCwdWithExtension
cwd
(ppSuffixes pps)
(map getSymbolicPath (hsSourceDirs exeBi))
(dropExtension mainPath)
case ppFile of
Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath
Just pp -> return pp
-- | Find a module definition file
--
-- TODO: I don't know if this is right
findModDefFile
:: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
findModDefFile verbosity cwd flibBi _pps modDefPath =
findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath
-- | Given a list of include paths, try to find the include file named
-- @f@. Return the name of the file and the full path, or exit with error if
-- there's no such file.
findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)
findIncludeFile verbosity _ [] f = dieWithException verbosity $ NoIncludeFileFound f
findIncludeFile verbosity cwd (d : ds) f = do
let path = (d </> f)
b <- doesFileExist (cwd </> path)
if b then return (f, path) else findIncludeFile verbosity cwd ds f
-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules'
-- and 'other-modules'.
filterAutogenModules :: PackageDescription -> PackageDescription
filterAutogenModules pkg_descr0 =
mapLib filterAutogenModuleLib $
mapAllBuildInfo filterAutogenModuleBI pkg_descr0
where
mapLib f pkg =
pkg
{ library = fmap f (library pkg)
, subLibraries = map f (subLibraries pkg)
}
filterAutogenModuleLib lib =
lib
{ exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)
}
filterAutogenModuleBI bi =
bi
{ otherModules = filter (filterFunction bi) (otherModules bi)
}
pathsModule = autogenPathsModuleName pkg_descr0
packageInfoModule = autogenPackageInfoModuleName pkg_descr0
filterFunction bi = \mn ->
mn /= pathsModule
&& mn /= packageInfoModule
&& not (mn `elem` autogenModules bi)
-- | Prepare a directory tree of source files for a snapshot version.
-- It is expected that the appropriate snapshot version has already been set
-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
prepareSnapshotTree
:: Verbosity
-- ^ verbosity
-> PackageDescription
-- ^ info from the cabal file
-> FilePath
-- ^ source tree to populate
-> [PPSuffixHandler]
-- ^ extra preprocessors (includes suffixes)
-> IO ()
prepareSnapshotTree verbosity pkg targetDir pps = do
prepareTree verbosity pkg targetDir pps
overwriteSnapshotPackageDesc verbosity pkg targetDir
overwriteSnapshotPackageDesc
:: Verbosity
-- ^ verbosity
-> PackageDescription
-- ^ info from the cabal file
-> FilePath
-- ^ source tree
-> IO ()
overwriteSnapshotPackageDesc verbosity pkg targetDir = do
-- We could just writePackageDescription targetDescFile pkg_descr,
-- but that would lose comments and formatting.
descFile <- defaultPackageDesc verbosity
withUTF8FileContents descFile $
writeUTF8File (targetDir </> descFile)
. unlines
. map (replaceVersion (packageVersion pkg))
. lines
where
replaceVersion :: Version -> String -> String
replaceVersion version line
| "version:" `isPrefixOf` map toLower line =
"version: " ++ prettyShow version
| otherwise = line
-- | Modifies a 'PackageDescription' by appending a snapshot number
-- corresponding to the given date.
snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
snapshotPackage date pkg =
pkg
{ package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)}
}
where
pkgid = packageId pkg
-- | Modifies a 'Version' by appending a snapshot number corresponding
-- to the given date.
snapshotVersion :: UTCTime -> Version -> Version
snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date])
-- | Given a date produce a corresponding integer representation.
-- For example given a date @18/03/2008@ produce the number @20080318@.
dateToSnapshotNumber :: UTCTime -> Int
dateToSnapshotNumber date = case toGregorian (utctDay date) of
(year, month, day) ->
fromIntegral year * 10000
+ month * 100
+ day
-- | Create an archive from a tree of source files, and clean up the tree.
createArchive
:: Verbosity
-- ^ verbosity
-> PackageDescription
-- ^ info from cabal file
-> FilePath
-- ^ source tree to archive
-> FilePath
-- ^ name of archive to create
-> IO FilePath
createArchive verbosity pkg_descr tmpDir targetPref = do
let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
(tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb
let formatOptSupported =
maybe False (== "YES") $
Map.lookup
"Supports --format"
(programProperties tarProg)
runProgram verbosity tarProg $
-- Hmm: I could well be skating on thinner ice here by using the -C option
-- (=> seems to be supported at least by GNU and *BSD tar) [The
-- prev. solution used pipes and sub-command sequences to set up the paths
-- correctly, which is problematic in a Windows setting.]
["-czf", tarBallFilePath, "-C", tmpDir]
++ (if formatOptSupported then ["--format", "ustar"] else [])
++ [tarBallName pkg_descr]
return tarBallFilePath
-- | Given a buildinfo, return the names of all source files.
allSourcesBuildInfo
:: Verbosity
-> (Verbosity -> CabalException -> IO [FilePath])
-- ^ 'die'' alternative.
-- Since 'die'' prefixes the error message with 'errorPrefix',
-- whatever is passed in here and wants to die should do the same.
-- See issue #7331.
-> FilePath
-- ^ cwd -- change me to 'BuildPath Absolute PackageDir'
-> BuildInfo
-> [PPSuffixHandler]
-- ^ Extra preprocessors
-> [ModuleName]
-- ^ Exposed modules
-> IO [FilePath]
allSourcesBuildInfo verbosity rip cwd bi pps modules = do
let searchDirs = map getSymbolicPath (hsSourceDirs bi)
sources <-
fmap concat $
sequenceA $
[ let file = ModuleName.toFilePath module_
in -- NB: *Not* findFileWithExtension, because the same source
-- file may show up in multiple paths due to a conditional;
-- we need to package all of them. See #367.
findAllFilesCwdWithExtension cwd suffixes searchDirs file
>>= nonEmpty' (notFound module_) return
| module_ <- modules ++ otherModules bi
]
bootFiles <-
sequenceA
[ let file = ModuleName.toFilePath module_
fileExts = ["hs-boot", "lhs-boot"]
in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file
| module_ <- modules ++ otherModules bi
]
return $
sources
++ catMaybes bootFiles
++ cSources bi
++ cxxSources bi
++ cmmSources bi
++ asmSources bi
++ jsSources bi
where
nonEmpty' :: b -> ([a] -> b) -> [a] -> b
nonEmpty' x _ [] = x
nonEmpty' _ f xs = f xs
suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"]
notFound :: ModuleName -> IO [FilePath]
notFound m =
rip verbosity $ NoModuleFound m suffixes
-- | Note: must be called with the CWD set to the directory containing
-- the '.cabal' file.
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems verbosity pkg_descr = do
ioChecks <- checkPackageFiles verbosity pkg_descr "."
let pureChecks = checkConfiguredPackage pkg_descr
(errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks)
unless (null errors) $
notice verbosity $
"Distribution quality errors:\n"
++ unlines (map ppPackageCheck errors)
unless (null warnings) $
notice verbosity $
"Distribution quality warnings:\n"
++ unlines (map ppPackageCheck warnings)
unless (null errors) $
notice
verbosity
"Note: the public hackage server would reject this package."
------------------------------------------------------------
-- | The name of the tarball without extension
tarBallName :: PackageDescription -> String
tarBallName = prettyShow . packageId
mapAllBuildInfo
:: (BuildInfo -> BuildInfo)
-> (PackageDescription -> PackageDescription)
mapAllBuildInfo f pkg =
pkg
{ library = fmap mapLibBi (library pkg)
, subLibraries = fmap mapLibBi (subLibraries pkg)
, foreignLibs = fmap mapFLibBi (foreignLibs pkg)
, executables = fmap mapExeBi (executables pkg)
, testSuites = fmap mapTestBi (testSuites pkg)
, benchmarks = fmap mapBenchBi (benchmarks pkg)
}
where
mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)}
mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)}
mapExeBi exe = exe{buildInfo = f (buildInfo exe)}
mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)}
mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)}