Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
eddcaf5b
Commit
eddcaf5b
authored
Feb 18, 2008
by
Duncan Coutts
Browse files
Add warnings about missing and out-of-tree relative paths
parent
328519b6
Changes
1
Hide whitespace changes
Inline
Side-by-side
Distribution/PackageDescription/Check.hs
View file @
eddcaf5b
...
...
@@ -47,8 +47,9 @@ module Distribution.PackageDescription.Check (
)
where
import
Data.Maybe
(
isNothing
,
catMaybes
)
import
Data.List
(
intersperse
,
sort
,
group
,
isPrefixOf
)
import
System.Directory
(
doesFileExist
)
import
Data.List
(
sort
,
group
,
isPrefixOf
)
import
Control.Monad
(
filterM
)
import
System.Directory
(
doesFileExist
,
doesDirectoryExist
)
import
Distribution.PackageDescription
import
Distribution.Compiler
(
CompilerFlavor
(
..
))
...
...
@@ -58,7 +59,7 @@ import Distribution.Simple.Utils (cabalVersion, intercalate)
import
Distribution.Version
(
Version
(
..
),
withinRange
,
showVersionRange
)
import
Distribution.Package
(
PackageIdentifier
(
..
))
import
Language.Haskell.Extension
(
Extension
(
..
))
import
System.FilePath
(
takeExtension
,
(
</>
))
import
System.FilePath
(
takeExtension
,
isRelative
,
splitDirectories
,
(
</>
))
-- | Results of some kind of failed package check.
--
...
...
@@ -118,6 +119,7 @@ checkPackage pkg =
++
checkLicense
pkg
++
checkGhcOptions
pkg
++
checkCCOptions
pkg
++
checkPaths
pkg
-- ------------------------------------------------------------
...
...
@@ -395,6 +397,22 @@ checkAlternatives badField goodField flags =
where
(
badFlags
,
goodFlags
)
=
unzip
flags
checkPaths
::
PackageDescription
->
[
PackageCheck
]
checkPaths
pkg
=
[
PackageBuildWarning
{
explanation
=
quote
(
kind
++
": "
++
dir
)
++
" is a relative path outside of the source tree.
\n
"
++
"This will not work when generating a tarball with 'sdist'."
}
|
bi
<-
allBuildInfo
pkg
,
(
dir
,
kind
)
<-
[
(
dir
,
"extra-lib-dirs"
)
|
dir
<-
extraLibDirs
bi
]
++
[
(
dir
,
"include-dirs"
)
|
dir
<-
includeDirs
bi
]
++
[
(
dir
,
"hs-source-dirs"
)
|
dir
<-
hsSourceDirs
bi
]
,
isOutsideTree
dir
]
where
isOutsideTree
dir
=
case
splitDirectories
dir
of
".."
:
_
->
True
_
->
False
-- ------------------------------------------------------------
-- * Checks in IO
-- ------------------------------------------------------------
...
...
@@ -407,8 +425,10 @@ checkPackageFiles pkg root = do
licenseError
<-
checkLicenseExists
pkg
root
setupError
<-
checkSetupExists
pkg
root
configureError
<-
checkConfigureExists
pkg
root
localPathErrors
<-
checkLocalPathsExist
pkg
root
return
(
catMaybes
[
licenseError
,
setupError
,
configureError
])
return
$
catMaybes
[
licenseError
,
setupError
,
configureError
]
++
localPathErrors
checkLicenseExists
::
PackageDescription
->
FilePath
->
IO
(
Maybe
PackageCheck
)
checkLicenseExists
pkg
root
...
...
@@ -439,6 +459,22 @@ checkConfigureExists PackageDescription { buildType = Just Configure } root = do
"The 'build-type' is 'Configure' but there is no 'configure' script."
checkConfigureExists
_
_
=
return
Nothing
checkLocalPathsExist
::
PackageDescription
->
FilePath
->
IO
[
PackageCheck
]
checkLocalPathsExist
pkg
root
=
do
let
dirs
=
[
(
dir
,
kind
)
|
bi
<-
allBuildInfo
pkg
,
(
dir
,
kind
)
<-
[
(
dir
,
"extra-lib-dirs"
)
|
dir
<-
extraLibDirs
bi
]
++
[
(
dir
,
"include-dirs"
)
|
dir
<-
includeDirs
bi
]
++
[
(
dir
,
"hs-source-dirs"
)
|
dir
<-
hsSourceDirs
bi
]
,
isRelative
dir
]
missing
<-
filterM
(
fmap
not
.
doesDirectoryExist
.
(
root
</>
)
.
fst
)
dirs
return
[
PackageBuildWarning
{
explanation
=
quote
(
kind
++
": "
++
dir
)
++
" directory does not exist."
}
|
(
dir
,
kind
)
<-
missing
]
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment