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
f7535b33
Commit
f7535b33
authored
Apr 30, 2008
by
Duncan Coutts
Browse files
Add replacement SetupWrapper module
Clearer code and a wider interface to give more control.
parent
a4e46349
Changes
2
Hide whitespace changes
Inline
Side-by-side
cabal-install/Hackage/SetupWrapper.hs
0 → 100644
View file @
f7535b33
-----------------------------------------------------------------------------
-- |
-- Module : Hackage.SetupWrapper
-- Copyright : (c) The University of Glasgow 2006,
-- Duncan Coutts 2008
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : alpha
-- Portability : portable
--
-- An interface to building and installing Cabal packages.
-- If the @Built-Type@ field is specified as something other than
-- 'Custom', and the current version of Cabal is acceptable, this performs
-- setup actions directly. Otherwise it builds the setup script and
-- runs it with the given arguments.
module
Hackage.SetupWrapper
(
setupWrapper
,
SetupScriptOptions
(
..
),
defaultSetupScriptOptions
,
)
where
import
qualified
Distribution.Make
as
Make
import
qualified
Distribution.Simple
as
Simple
import
Distribution.Version
(
VersionRange
(
..
),
withinRange
)
import
Distribution.Package
(
PackageIdentifier
,
packageVersion
,
packageId
,
Dependency
(
..
)
)
import
Distribution.PackageDescription
(
GenericPackageDescription
(
packageDescription
)
,
PackageDescription
(
..
),
BuildType
(
..
)
)
import
Distribution.PackageDescription.Parse
(
readPackageDescription
)
import
Distribution.InstalledPackageInfo
(
InstalledPackageInfo
)
import
Distribution.Simple.Configure
(
configCompiler
,
getInstalledPackages
)
import
Distribution.Simple.Compiler
(
CompilerFlavor
(
GHC
),
Compiler
,
PackageDB
(
..
)
)
import
Distribution.Simple.Program
(
ProgramConfiguration
,
emptyProgramConfiguration
,
rawSystemProgramConf
,
ghcProgram
)
import
Distribution.Simple.BuildPaths
(
distPref
,
exeExtension
)
import
Distribution.Simple.Command
(
CommandUI
(
..
),
commandShowOptions
)
import
Distribution.Simple.GHC
(
ghcVerbosityOptions
)
import
qualified
Distribution.Simple.PackageIndex
as
PackageIndex
import
Distribution.Simple.PackageIndex
(
PackageIndex
)
import
Distribution.Simple.Utils
(
die
,
debug
,
comparing
,
cabalVersion
,
defaultPackageDesc
,
rawSystemExit
,
createDirectoryIfMissingVerbose
)
import
Distribution.Text
(
display
)
import
Distribution.Verbosity
(
Verbosity
)
import
System.Directory
(
doesFileExist
,
getModificationTime
)
import
System.FilePath
(
(
</>
),
(
<.>
)
)
import
System.IO.Error
(
isDoesNotExistError
)
import
Control.Monad
(
when
,
unless
)
import
Control.Exception
(
evaluate
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Monoid
(
Monoid
(
mempty
)
)
import
Data.List
(
maximumBy
)
data
SetupScriptOptions
=
SetupScriptOptions
{
useCabalVersion
::
VersionRange
,
useCompiler
::
Maybe
Compiler
,
usePackageIndex
::
Maybe
(
PackageIndex
InstalledPackageInfo
),
useProgramConfig
::
ProgramConfiguration
}
defaultSetupScriptOptions
::
SetupScriptOptions
defaultSetupScriptOptions
=
SetupScriptOptions
{
useCabalVersion
=
AnyVersion
,
useCompiler
=
Nothing
,
usePackageIndex
=
Nothing
,
useProgramConfig
=
emptyProgramConfiguration
}
setupWrapper
::
Verbosity
->
SetupScriptOptions
->
Maybe
PackageDescription
->
CommandUI
flags
->
flags
->
[
String
]
->
IO
()
setupWrapper
verbosity
options
mpkg
cmd
flags
extraArgs
=
do
pkg
<-
maybe
getPkg
return
mpkg
let
setupMethod
=
determineSetupMethod
options'
buildType'
options'
=
options
{
useCabalVersion
=
IntersectVersionRanges
(
useCabalVersion
options
)
(
descCabalVersion
pkg
)
}
buildType'
=
fromMaybe
Custom
(
buildType
pkg
)
args
=
commandName
cmd
:
commandShowOptions
cmd
flags
++
extraArgs
setupMethod
verbosity
buildType'
args
where
getPkg
=
defaultPackageDesc
verbosity
>>=
readPackageDescription
verbosity
>>=
return
.
packageDescription
-- | Decide if we're going to be able to do a direct internal call to the
-- entry point in the Cabal library or if we're going to have to compile
-- and execute an external Setup.hs script.
--
determineSetupMethod
::
SetupScriptOptions
->
BuildType
->
SetupMethod
determineSetupMethod
options
buildType'
|
buildType'
==
Custom
=
externalSetupMethod
options
|
cabalVersion
`
withinRange
`
useCabalVersion
options
=
internalSetupMethod
|
otherwise
=
externalSetupMethod
options
type
SetupMethod
=
Verbosity
->
BuildType
->
[
String
]
->
IO
()
-- ------------------------------------------------------------
-- * Internal SetupMethod
-- ------------------------------------------------------------
internalSetupMethod
::
SetupMethod
internalSetupMethod
verbosity
bt
args
=
do
debug
verbosity
$
"internalSetupMethod "
++
show
bt
++
" "
++
show
args
buildTypeAction
bt
args
buildTypeAction
::
BuildType
->
([
String
]
->
IO
()
)
buildTypeAction
Simple
=
Simple
.
defaultMainArgs
buildTypeAction
Configure
=
Simple
.
defaultMainWithHooksArgs
Simple
.
autoconfUserHooks
buildTypeAction
Make
=
Make
.
defaultMainArgs
buildTypeAction
Custom
=
error
"buildTypeAction Custom"
buildTypeAction
(
UnknownBuildType
_
)
=
error
"buildTypeAction UnknownBuildType"
-- ------------------------------------------------------------
-- * External SetupMethod
-- ------------------------------------------------------------
externalSetupMethod
::
SetupScriptOptions
->
SetupMethod
externalSetupMethod
options
verbosity
bt
args
=
updateSetupScript
verbosity
bt
>>=
compileSetupExecutable
verbosity
options
>>
invokeSetupScript
verbosity
args
-- | Decide which Setup.hs script to use, creating it if necessary.
--
updateSetupScript
::
Verbosity
->
BuildType
->
IO
FilePath
updateSetupScript
_
Custom
=
do
useHs
<-
doesFileExist
"Setup.hs"
useLhs
<-
doesFileExist
"Setup.lhs"
unless
(
useHs
||
useLhs
)
$
die
"Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."
return
(
if
useHs
then
"Setup.hs"
else
"Setup.lhs"
)
updateSetupScript
verbosity
bt
=
do
createDirectoryIfMissingVerbose
verbosity
True
setupDir
rewriteFile
setupHs
(
buildTypeScript
bt
)
return
setupHs
where
setupDir
=
distPref
</>
"setup"
setupHs
=
setupDir
</>
"setup"
<.>
"hs"
buildTypeScript
::
BuildType
->
String
buildTypeScript
Simple
=
"import Distribution.Simple; main = defaultMain"
buildTypeScript
Configure
=
"import Distribution.Simple; "
++
"main = defaultMainWithHooks autoconfUserHooks"
buildTypeScript
Make
=
"import Distribution.Make; main = defaultMain"
buildTypeScript
Custom
=
error
"buildTypeScript Custom"
buildTypeScript
(
UnknownBuildType
_
)
=
error
"buildTypeScript UnknownBuildType"
-- | If the Setup.hs is out of date wrt the executable then recompile it.
-- Currently this is GHC only. It should really be generalised.
--
compileSetupExecutable
::
Verbosity
->
SetupScriptOptions
->
FilePath
->
IO
()
compileSetupExecutable
verbosity
options
setupHs
=
do
outOfDate
<-
setupHs
`
moreRecentFile
`
setupProg
when
outOfDate
$
do
cabalPkgId
<-
installedCabalLibVer
verbosity
options
createDirectoryIfMissingVerbose
verbosity
True
setupDir
rawSystemProgramConf
verbosity
ghcProgram
(
useProgramConfig
options
)
$
ghcVerbosityOptions
verbosity
++
[
"--make"
,
setupHs
,
"-o"
,
setupProg
,
"-package"
,
display
cabalPkgId
,
"-odir"
,
setupDir
,
"-hidir"
,
setupDir
]
where
setupDir
=
distPref
</>
"setup"
setupProg
=
setupDir
</>
"setup"
<.>
exeExtension
installedCabalLibVer
::
Verbosity
->
SetupScriptOptions
->
IO
PackageIdentifier
installedCabalLibVer
verbosity
options
=
do
index
<-
case
usePackageIndex
options
of
Just
index
->
return
index
Nothing
->
do
(
comp
,
conf
)
<-
case
useCompiler
options
of
Just
comp
->
return
(
comp
,
useProgramConfig
options
)
Nothing
->
configCompiler
(
Just
GHC
)
Nothing
Nothing
(
useProgramConfig
options
)
verbosity
fromMaybe
mempty
`
fmap
`
getInstalledPackages
verbosity
comp
UserPackageDB
conf
-- user packages are *allowed* here, no portability problem
let
cabalDep
=
Dependency
"Cabal"
(
useCabalVersion
options
)
case
PackageIndex
.
lookupDependency
index
cabalDep
of
[]
->
die
$
"The package requires Cabal library version "
++
display
(
useCabalVersion
options
)
++
" but no suitable version is installed."
pkgs
->
return
$
maximumBy
(
comparing
packageVersion
)
(
map
packageId
pkgs
)
invokeSetupScript
::
Verbosity
->
[
String
]
->
IO
()
invokeSetupScript
verbosity
args
=
rawSystemExit
verbosity
setupProg
args
where
setupProg
=
distPref
</>
"setup"
</>
"setup"
<.>
exeExtension
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
-- | Compare the modification times of two files to see if the first is newer
-- than the second. The first file must exist but the second need not.
-- The expected use case is when the second file is generated using the first.
-- In this use case, if the result is True then the second file is out of date.
--
moreRecentFile
::
FilePath
->
FilePath
->
IO
Bool
moreRecentFile
a
b
=
do
exists
<-
doesFileExist
b
if
not
exists
then
return
True
else
do
tb
<-
getModificationTime
b
ta
<-
getModificationTime
a
return
(
ta
>
tb
)
-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
-- update the file's modification time.
--
rewriteFile
::
FilePath
->
String
->
IO
()
rewriteFile
path
newContent
=
flip
catch
mightNotExist
$
do
existingContent
<-
readFile
path
evaluate
(
length
existingContent
)
unless
(
existingContent
==
newContent
)
$
writeFile
path
newContent
where
mightNotExist
e
|
isDoesNotExistError
e
=
writeFile
path
newContent
|
otherwise
=
ioError
e
cabal-install/cabal-install.cabal
View file @
f7535b33
...
...
@@ -12,11 +12,13 @@ Author: Lemmih <lemmih@gmail.com>
Paolo Martini <paolo@nemail.it>
Bjorn Bringert <bjorn@bringert.net>
Isaac Potoczny-Jones <ijones@syntaxpolice.org>
Duncan Coutts <duncan@haskell.org>
Maintainer: cabal-devel@haskell.org
Copyright: 2005 Lemmih <lemmih@gmail.com>
2006 Paolo Martini <paolo@nemail.it>
2007 Bjorn Bringert <bjorn@bringert.net>
2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>
2008 Duncan Coutts <duncan@haskell.org>
Stability: Experimental
Category: Distribution
Build-type: Simple
...
...
@@ -34,18 +36,20 @@ Executable cabal
Ghc-Options: -Wall
Other-Modules:
Hackage.Check
Hackage.Clean
--
Hackage.Clean
Hackage.Config
Hackage.Dependency
Hackage.DepGraph
Hackage.Fetch
Hackage.HttpUtils
Hackage.IndexUtils
Hackage.Info
--
Hackage.Info
Hackage.Install
-- Hackage.InstallPlan
Hackage.List
Hackage.ParseUtils
Hackage.Setup
Hackage.SetupWrapper
Hackage.SrcDist
Hackage.Tar
Hackage.Types
...
...
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