Commit 19688b49 authored by Duncan Coutts's avatar Duncan Coutts

Replace command line handling

Use the new cabal command line handling infrastructure. Use proper flag types
rather than strings. 
Drop support for per-package command line flags as it was generally agreed to
be confusing.
parent 24a5fcda
......@@ -28,6 +28,7 @@ import Control.Monad (when)
import Data.Char (isAlphaNum, toLower)
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import System.Directory (createDirectoryIfMissing, getAppUserDataDirectory)
import System.FilePath ((</>), takeDirectory, (<.>))
import System.IO (hPutStrLn, stderr)
......@@ -41,7 +42,7 @@ import Distribution.ParseUtils (FieldDescr(..), simpleField, listField, liftFiel
import Distribution.Simple.Compiler (Compiler, PackageDB(..))
import Distribution.Simple.Configure (getInstalledPackages)
import qualified Distribution.Simple.Configure as Configure (configCompiler)
import Distribution.Simple.InstallDirs (InstallDirTemplates(..), PathTemplate, toPathTemplate, defaultInstallDirs)
import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, toPathTemplate)
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
import Distribution.Version (showVersion)
import Distribution.Verbosity (Verbosity, normal)
......@@ -118,26 +119,26 @@ defaultCacheDir = do dir <- defaultCabalDir
defaultCompiler :: CompilerFlavor
defaultCompiler = fromMaybe GHC defaultCompilerFlavor
defaultUserInstallDirs :: CompilerFlavor -> IO InstallDirTemplates
defaultUserInstallDirs compiler =
do installDirs <- defaultInstallDirs compiler True
userPrefix <- defaultCabalDir
return $ installDirs { prefixDirTemplate = toPathTemplate userPrefix }
defaultUserInstallDirs :: IO (InstallDirs (Maybe PathTemplate))
defaultUserInstallDirs =
do userPrefix <- defaultCabalDir
return $ defaultGlobalInstallDirs {
prefix = Just (toPathTemplate userPrefix)
}
defaultGlobalInstallDirs :: CompilerFlavor -> IO InstallDirTemplates
defaultGlobalInstallDirs compiler = defaultInstallDirs compiler True
defaultGlobalInstallDirs :: InstallDirs (Maybe PathTemplate)
defaultGlobalInstallDirs = fmap (\() -> Nothing) mempty
defaultConfigFlags :: IO ConfigFlags
defaultConfigFlags =
do userInstallDirs <- defaultUserInstallDirs defaultCompiler
globalInstallDirs <- defaultGlobalInstallDirs defaultCompiler
do userInstallDirs <- defaultUserInstallDirs
cacheDir <- defaultCacheDir
return $ ConfigFlags
{ configCompiler = defaultCompiler
, configCompilerPath = Nothing
, configHcPkgPath = Nothing
, configUserInstallDirs = userInstallDirs
, configGlobalInstallDirs = globalInstallDirs
, configGlobalInstallDirs = defaultGlobalInstallDirs
, configCacheDir = cacheDir
, configRepos = [Repo "hackage.haskell.org" "http://hackage.haskell.org/packages/archive"]
, configVerbose = normal
......@@ -198,34 +199,34 @@ configWriteFieldDescrs =
, boolField "user-install" configUserInstall (\u cfg -> cfg { configUserInstall = u })
]
installDirDescrs :: [FieldDescr InstallDirTemplates]
installDirDescrs :: [FieldDescr (InstallDirs (Maybe PathTemplate))]
installDirDescrs =
[ installDirField "prefix" prefixDirTemplate (\d ds -> ds { prefixDirTemplate = d })
, installDirField "bindir" binDirTemplate (\d ds -> ds { binDirTemplate = d })
, installDirField "libdir" libDirTemplate (\d ds -> ds { libDirTemplate = d })
, installDirField "libexecdir" libexecDirTemplate (\d ds -> ds { libexecDirTemplate = d })
, installDirField "datadir" dataDirTemplate (\d ds -> ds { dataDirTemplate = d })
, installDirField "docdir" docDirTemplate (\d ds -> ds { docDirTemplate = d })
, installDirField "htmldir" htmlDirTemplate (\d ds -> ds { htmlDirTemplate = d })
[ installDirField "prefix" prefix (\d ds -> ds { prefix = d })
, installDirField "bindir" bindir (\d ds -> ds { bindir = d })
, installDirField "libdir" libdir (\d ds -> ds { libdir = d })
, installDirField "libexecdir" libexecdir (\d ds -> ds { libexecdir = d })
, installDirField "datadir" datadir (\d ds -> ds { datadir = d })
, installDirField "docdir" docdir (\d ds -> ds { docdir = d })
, installDirField "htmldir" htmldir (\d ds -> ds { htmldir = d })
]
userInstallDirField :: FieldDescr InstallDirTemplates -> FieldDescr ConfigFlags
userInstallDirField :: FieldDescr (InstallDirs (Maybe PathTemplate)) -> FieldDescr ConfigFlags
userInstallDirField f = modifyFieldName ("user-"++) $
liftField configUserInstallDirs
(\d cfg -> cfg { configUserInstallDirs = d })
f
globalInstallDirField :: FieldDescr InstallDirTemplates -> FieldDescr ConfigFlags
globalInstallDirField :: FieldDescr (InstallDirs (Maybe PathTemplate)) -> FieldDescr ConfigFlags
globalInstallDirField f = modifyFieldName ("global-"++) $
liftField configGlobalInstallDirs
(\d cfg -> cfg { configGlobalInstallDirs = d })
f
installDirField :: String
-> (InstallDirTemplates -> PathTemplate)
-> (PathTemplate -> InstallDirTemplates -> InstallDirTemplates)
-> FieldDescr InstallDirTemplates
-> (InstallDirs (Maybe PathTemplate) -> Maybe PathTemplate)
-> (Maybe PathTemplate -> InstallDirs (Maybe PathTemplate) -> InstallDirs (Maybe PathTemplate))
-> FieldDescr (InstallDirs (Maybe PathTemplate))
installDirField name get set =
liftField get set $ field name (text . show) (readS_to_P reads)
......
......@@ -20,7 +20,8 @@ module Hackage.Dependency
import Hackage.Config (listInstalledPackages)
import Hackage.Index (getKnownPackages)
import Hackage.Types
(ResolvedPackage(..), UnresolvedDependency(..), ConfigFlags (..), PkgInfo (..))
(ResolvedPackage(..), UnresolvedDependency(..), ConfigFlags (..),
PkgInfo (..), FlagAssignment)
import Distribution.Version (Dependency(..), withinRange)
import Distribution.Package (PackageIdentifier(..))
......@@ -30,10 +31,10 @@ import Distribution.PackageDescription
, finalizePackageDescription)
import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerVersion)
import Distribution.Simple.Program (ProgramConfiguration)
import qualified Distribution.Simple.Setup as Cabal
import Control.Monad (mplus)
import Data.Char (toLower)
import Data.List (nub, nubBy, maximumBy, isPrefixOf)
import Data.List (nub, nubBy, maximumBy)
import Data.Maybe (fromMaybe)
import qualified System.Info (arch,os)
......@@ -46,8 +47,8 @@ resolveDependencies :: ConfigFlags
resolveDependencies cfg comp conf deps
= do installed <- listInstalledPackages cfg comp conf
available <- getKnownPackages cfg
return [resolveDependency comp installed available dep opts
| UnresolvedDependency dep opts <- deps]
return [resolveDependency comp installed available dep flags
| UnresolvedDependency dep flags <- deps]
-- | Resolve dependencies of a local package description. This is used
-- when the top-level package does not come from hackage.
......@@ -55,29 +56,29 @@ resolveDependenciesLocal :: ConfigFlags
-> Compiler
-> ProgramConfiguration
-> GenericPackageDescription
-> [String]
-> FlagAssignment
-> IO [ResolvedPackage]
resolveDependenciesLocal cfg comp conf desc opts
resolveDependenciesLocal cfg comp conf desc flags
= do installed <- listInstalledPackages cfg comp conf
available <- getKnownPackages cfg
return [resolveDependency comp installed available dep []
| dep <- getDependencies comp installed available desc opts]
| dep <- getDependencies comp installed available desc flags]
resolveDependency :: Compiler
-> [PackageIdentifier] -- ^ Installed packages.
-> [PkgInfo] -- ^ Installable packages
-> Dependency
-> [String] -- ^ Options for this dependency
-> FlagAssignment
-> ResolvedPackage
resolveDependency comp installed available dep opts
resolveDependency comp installed available dep flags
= fromMaybe (Unavailable dep) $ resolveFromInstalled `mplus` resolveFromAvailable
where
resolveFromInstalled = fmap (Installed dep) $ latestInstalledSatisfying installed dep
resolveFromAvailable =
do pkg <- latestAvailableSatisfying available dep
let deps = getDependencies comp installed available (pkgDesc pkg) opts
let deps = getDependencies comp installed available (pkgDesc pkg) flags
resolved = map (\d -> resolveDependency comp installed available d []) deps
return $ Available dep pkg opts resolved
return $ Available dep pkg flags resolved
-- | Gets the latest installed package satisfying a dependency.
latestInstalledSatisfying :: [PackageIdentifier]
......@@ -109,17 +110,16 @@ getDependencies :: Compiler
-> [PackageIdentifier] -- ^ Installed packages.
-> [PkgInfo] -- ^ Available packages
-> GenericPackageDescription
-> [String] -- ^ Options
-> FlagAssignment
-> [Dependency]
-- ^ If successful, this is the list of dependencies.
-- If flag assignment failed, this is the list of
-- missing dependencies.
getDependencies comp installed available pkg opts
getDependencies comp installed available pkg flags
= case e of
Left missing -> missing
Right (desc,_) -> buildDepends desc
where
flags = configurationsFlags opts
e = finalizePackageDescription
flags
(Just $ nub $ installed ++ map pkgInfoId available)
......@@ -128,20 +128,8 @@ getDependencies comp installed available pkg opts
(showCompilerId comp, compilerVersion comp)
pkg
-- | Extracts configurations flags from a list of options.
configurationsFlags :: [String] -> [(String, Bool)]
configurationsFlags = concatMap flag
where
flag o | "--flags=" `isPrefixOf` o = map tagWithValue $ words $ removeQuotes $ drop 8 o
| "-f" `isPrefixOf` o = [tagWithValue $ drop 2 o]
| otherwise = []
removeQuotes (c:s) | c == '"' || c == '\'' = take (length s - 1) s
removeQuotes s = s
tagWithValue ('-':name) = (map toLower name, False)
tagWithValue name = (map toLower name, True)
packagesToInstall :: [ResolvedPackage]
-> Either [Dependency] [(PkgInfo, [String])]
-> Either [Dependency] [(PkgInfo, FlagAssignment)]
-- ^ Either a list of missing dependencies, or a list
-- of packages to install, with their options.
packagesToInstall xs | null missing = Right toInstall
......
......@@ -49,14 +49,15 @@ infoPkg :: ConfigFlags -> ResolvedPackage -> IO ()
infoPkg _ (Installed dep p)
= do printf " Requested: %s\n" (show $ showDependency dep)
printf " Installed: %s\n\n" (showPackageId p)
infoPkg cfg (Available dep pkg opts deps)
infoPkg cfg (Available dep pkg flags deps)
= do fetched <- isFetched cfg pkg
let pkgFile = if fetched then packageFile cfg pkg
else "*Not downloaded"
printf " Requested: %s\n" (show $ showDependency dep)
printf " Using: %s\n" (showPackageId (pkgInfoId pkg))
printf " Depends: %s\n" (showDependencies $ map fulfills deps)
printf " Options: %s\n" (unwords opts)
printf " Options: %s\n" (unwords [ if set then flag else '-':flag
| (flag, set) <- flags ])
printf " Location: %s\n" (pkgURL pkg)
printf " Local: %s\n\n" pkgFile
infoPkg _ (Unavailable dep)
......
......@@ -16,6 +16,7 @@ module Hackage.Install
import Control.Exception (bracket_)
import Control.Monad (when)
import Data.Monoid (Monoid(mempty))
import System.Directory (getTemporaryDirectory, createDirectoryIfMissing
,removeDirectoryRecursive, doesFileExist)
import System.FilePath ((</>),(<.>))
......@@ -28,85 +29,54 @@ import Hackage.Dependency (resolveDependencies, resolveDependenciesLocal, packag
import Hackage.Fetch (fetchPackage)
import Hackage.Tar (extractTarGzFile)
import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..)
, PkgInfo(..))
, PkgInfo(..), FlagAssignment)
import Hackage.Utils
import Distribution.Simple.Compiler (Compiler(..))
import Distribution.Simple.InstallDirs (InstallDirs(..), absoluteInstallDirs)
import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.Simple.Compiler (Compiler, PackageDB(..))
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
import Distribution.Simple.Command (commandShowOptions)
import Distribution.Simple.SetupWrapper (setupWrapper)
import Distribution.Simple.Setup (CopyDest(..))
import Distribution.Simple.Setup (toFlag)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils (defaultPackageDesc)
import Distribution.Package (showPackageId, PackageIdentifier(..))
import Distribution.PackageDescription (packageDescription, readPackageDescription, package)
import Distribution.PackageDescription (readPackageDescription)
import Distribution.Verbosity
-- |Installs the packages needed to satisfy a list of dependencies.
install :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()
install cfg comp conf globalArgs deps
| null deps = installLocalPackage cfg comp conf globalArgs
| otherwise = installRepoPackages cfg comp conf globalArgs deps
install :: ConfigFlags -> Compiler -> ProgramConfiguration -> Cabal.ConfigFlags -> [UnresolvedDependency] -> IO ()
install cfg comp conf configFlags deps
| null deps = installLocalPackage cfg comp conf configFlags
| otherwise = installRepoPackages cfg comp conf configFlags deps
-- | Install the unpacked package in the current directory, and all its dependencies.
installLocalPackage :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> IO ()
installLocalPackage cfg comp conf globalArgs =
installLocalPackage :: ConfigFlags -> Compiler -> ProgramConfiguration -> Cabal.ConfigFlags -> IO ()
installLocalPackage cfg comp conf configFlags =
do cabalFile <- defaultPackageDesc (configVerbose cfg)
desc <- readPackageDescription (configVerbose cfg) cabalFile
resolvedDeps <- resolveDependenciesLocal cfg comp conf desc globalArgs
resolvedDeps <- resolveDependenciesLocal cfg comp conf desc
(Cabal.configConfigurationsFlags configFlags)
case packagesToInstall resolvedDeps of
Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing
Right pkgs -> installPackages cfg comp globalArgs pkgs
let pkgId = package (packageDescription desc)
installUnpackedPkg cfg comp globalArgs pkgId [] Nothing
Right pkgs -> installPackages cfg configFlags pkgs
installUnpackedPkg cfg configFlags Nothing
installRepoPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()
installRepoPackages cfg comp conf globalArgs deps =
installRepoPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> Cabal.ConfigFlags -> [UnresolvedDependency] -> IO ()
installRepoPackages cfg comp conf configFlags deps =
do resolvedDeps <- resolveDependencies cfg comp conf deps
case packagesToInstall resolvedDeps of
Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing
Right [] -> message cfg normal "All requested packages already installed. Nothing to do."
Right pkgs -> installPackages cfg comp globalArgs pkgs
-- Attach the correct prefix flag to configure commands,
-- correct --user flag to install commands and no options to other commands.
mkPkgOps :: ConfigFlags -> Compiler -> PackageIdentifier -> String -> [String] -> [String]
mkPkgOps cfg comp pkgId cmd ops = verbosity ++
case cmd of
"configure" -> user ++ hcPath ++ hcPkgPath ++ installDirFlags installDirs ++ ops
"install" -> user
_ -> []
where verbosity = ["-v" ++ showForCabal (configVerbose cfg)]
user = if configUserInstall cfg then ["--user"] else []
hcPath = maybe [] (\path -> ["--with-compiler=" ++ path]) (configCompilerPath cfg)
hcPkgPath = maybe [] (\path -> ["--with-hc-pkg=" ++ path]) (configHcPkgPath cfg)
installDirTemplates | configUserInstall cfg = configUserInstallDirs cfg
| otherwise = configGlobalInstallDirs cfg
installDirs = absoluteInstallDirs pkgId (compilerId comp) NoCopyDest installDirTemplates
installDirFlags :: InstallDirs FilePath -> [String]
installDirFlags dirs =
[flag "prefix" prefix,
flag "bindir" bindir,
flag "libdir" libdir,
-- flag "dynlibdir" dynlibdir, -- not accepted as argument by cabal?
flag "libexecdir" libexecdir,
-- flag "progdir" progdir, -- not accepted as argument by cabal?
-- flag "includedir" includedir, -- not accepted as argument by cabal?
flag "datadir" datadir,
flag "docdir" docdir,
flag "htmldir" htmldir]
where flag s f = "--" ++ s ++ "=" ++ f dirs
Right pkgs -> installPackages cfg configFlags pkgs
installPackages :: ConfigFlags
-> Compiler
-> [String] -- ^Options which will be parse to every package.
-> [(PkgInfo,[String])] -- ^ (Package, list of configure options)
-> Cabal.ConfigFlags -- ^Options which will be passed to every package.
-> [(PkgInfo,FlagAssignment)] -- ^ (Package, list of configure options)
-> IO ()
installPackages cfg comp globalArgs pkgs =
mapM_ (installPkg cfg comp globalArgs) pkgs
installPackages cfg configFlags = mapM_ (installPkg cfg configFlags)
{-|
......@@ -130,11 +100,10 @@ installPackages cfg comp globalArgs pkgs =
* The installation finishes by deleting the unpacked tarball.
-}
installPkg :: ConfigFlags
-> Compiler
-> [String] -- ^Options which will be parse to every package.
-> (PkgInfo,[String]) -- ^(Package, list of configure options)
-> Cabal.ConfigFlags -- ^Options which will be parse to every package.
-> (PkgInfo,FlagAssignment) -- ^(Package, list of configure options)
-> IO ()
installPkg cfg comp globalArgs (pkg,opts)
installPkg cfg configFlags (pkg,flags)
= do pkgPath <- fetchPackage cfg pkg
tmp <- getTemporaryDirectory
let p = pkgInfoId pkg
......@@ -147,22 +116,41 @@ installPkg cfg comp globalArgs (pkg,opts)
let descFilePath = tmpDirPath </> showPackageId p </> pkgName p <.> "cabal"
e <- doesFileExist descFilePath
when (not e) $ fail $ "Package .cabal file not found: " ++ show descFilePath
installUnpackedPkg cfg comp globalArgs p opts (Just path)
return ())
let configFlags' = configFlags {
Cabal.configConfigurationsFlags =
Cabal.configConfigurationsFlags configFlags ++ flags }
installUnpackedPkg cfg configFlags' (Just path))
installUnpackedPkg :: ConfigFlags -> Compiler
-> [String] -- ^ Arguments for all packages
-> PackageIdentifier
-> [String] -- ^ Arguments for this package
installUnpackedPkg :: ConfigFlags
-> Cabal.ConfigFlags -- ^ Arguments for this package
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> IO ()
installUnpackedPkg cfg comp globalArgs pkgId opts mpath
= do setup "configure"
setup "build"
setup "install"
installUnpackedPkg cfg configFlags mpath
= do setup ("configure" : configureOptions)
setup ["build"]
setup ["install"]
where
setup cmd
= do let cmdOps = mkPkgOps cfg comp pkgId cmd (globalArgs++opts)
message cfg verbose $
unwords ["setupWrapper", show (cmd:cmdOps), show mpath]
setupWrapper (cmd:cmdOps) mpath
configureOptions = mkPkgOps cfg configFlags
setup cmds
= do message cfg verbose $
"setupWrapper in " ++ show mpath ++ " :\n " ++ show cmds
setupWrapper cmds mpath
-- Attach the correct prefix flag to configure commands,
-- correct --user flag to install commands and no options to other commands.
mkPkgOps :: ConfigFlags -> Cabal.ConfigFlags -> [String]
mkPkgOps cfg configFlags =
commandShowOptions (Cabal.configureCommand defaultProgramConfiguration) configFlags {
Cabal.configHcFlavor = toFlag (configCompiler cfg),
Cabal.configHcPath = maybe (Cabal.configHcPath configFlags)
toFlag (configCompilerPath cfg),
Cabal.configHcPkg = maybe (Cabal.configHcPkg configFlags)
toFlag (configHcPkgPath cfg),
Cabal.configInstallDirs = fmap (maybe mempty toFlag) installDirTemplates,
Cabal.configVerbose = toFlag (configVerbose cfg),
Cabal.configPackageDB = if configUserInstall cfg
then toFlag UserPackageDB
else toFlag GlobalPackageDB
}
where installDirTemplates | configUserInstall cfg = configUserInstallDirs cfg
| otherwise = configGlobalInstallDirs cfg
......@@ -11,194 +11,147 @@
--
-----------------------------------------------------------------------------
module Hackage.Setup
( parsePackageArgs
, parseGlobalArgs
, configFromOptions
( globalCommand, Cabal.GlobalFlags(..)
, installCommand --Cabal.InstallFlags(..)
, listCommand
, updateCommand
, infoCommand
, fetchCommand
, parsePackageArgs
, updateConfig
) where
import Control.Monad (when)
import Distribution.Compiler (CompilerFlavor(..))
import Distribution.Simple.InstallDirs (InstallDirTemplates(..), toPathTemplate)
import Distribution.Verbosity
import Data.List (find)
import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), usageInfo, getOpt')
import System.Exit (exitWith, ExitCode (..))
import System.Environment (getProgName)
import Hackage.Types (Action (..), Option(..), ConfigFlags(..)
, UnresolvedDependency (..))
import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.Simple.Compiler (PackageDB(..))
import Distribution.Simple.InstallDirs (combineInstallDirs)
import Distribution.Simple.Command
import qualified Distribution.Simple.Setup as Cabal
(GlobalFlags(..), {-emptyGlobalFlags,-} globalCommand,
ConfigFlags(..), {-emptyConfigFlags,-} configureCommand,
{- CopyFlags(..), emptyCopyFlags, copyCommand,
InstallFlags(..), emptyInstallFlags, installCommand,
HaddockFlags(..), emptyHaddockFlags, haddockCommand,
HscolourFlags(..), emptyHscolourFlags, hscolourCommand,
BuildFlags(..), emptyBuildFlags, buildCommand,
CleanFlags(..), emptyCleanFlags, cleanCommand,
PFEFlags(..), emptyPFEFlags, programaticaCommand,
MakefileFlags(..), emptyMakefileFlags, makefileCommand,
RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand,
SDistFlags(..), emptySDistFlags, sdistCommand,
testCommand-})
import Distribution.Simple.Setup (fromFlagOrDefault, flagToMaybe)
--import System.Console.GetOpt (ArgDescr (..), OptDescr (..))
import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..))
import Hackage.Utils (readPToMaybe, parseDependencyOrPackageId)
globalOptions :: [OptDescr Option]
globalOptions =
[ Option "g" ["ghc"] (NoArg (OptCompilerFlavor GHC)) "Compile with GHC"
, Option "n" ["nhc"] (NoArg (OptCompilerFlavor NHC)) "Compile with NHC"
, Option "" ["hugs"] (NoArg (OptCompilerFlavor Hugs)) "Compile with hugs"
, Option "w" ["with-compiler"] (reqPathArg OptCompiler)
"Give the path to a particular compiler"
, Option "" ["with-hc-pkg"] (reqPathArg OptHcPkg)
"Give the path to the package tool"
, Option "c" ["config-file"] (reqPathArg OptConfigFile)
("Override the path to the config dir.")
, Option "" ["cache-dir"] (reqPathArg OptCacheDir)
("Override the path to the package cache dir.")
, Option "" ["prefix"] (reqDirArg OptPrefix)
"Bake this prefix in preparation of installation"
, Option "" ["bindir"] (reqDirArg OptBinDir)
"Installation directory for executables"
, Option "" ["libdir"] (reqDirArg OptLibDir)
"Installation directory for libraries"
, Option "" ["libsubdir"] (reqDirArg OptLibSubDir)
"Subdirectory of libdir in which libs are installed"
, Option "" ["libexecdir"] (reqDirArg OptLibExecDir)
"Installation directory for program executables"
, Option "" ["datadir"] (reqDirArg OptDataDir)
"Installation directory for read-only data"
, Option "" ["datasubdir"] (reqDirArg OptDataSubDir)
"Subdirectory of datadir in which data files are installed"
, Option "" ["docdir"] (reqDirArg OptDocDir)
"Installation directory for documentation"
, Option "" ["htmldir"] (reqDirArg OptHtmlDir)
"Installation directory for HTML documentation"
, Option "" ["user"] (NoArg (OptUserInstall True))
"Upon registration, register this package in the user's local package database"
, Option "" ["global"] (NoArg (OptUserInstall False))
"Upon registration, register this package in the system-wide package database"
, Option "h?" ["help"] (NoArg OptHelp) "Show this help text"
, Option "v" ["verbose"] (OptArg (OptVerbose . flagToVerbosity) "n")
"Control verbosity (n is 0--3, normal verbosity level is 1, -v alone is equivalent to -v2)"
]
reqPathArg :: (FilePath -> a) -> ArgDescr a
reqPathArg constr = ReqArg constr "PATH"
reqDirArg :: (FilePath -> a) -> ArgDescr a
reqDirArg constr = ReqArg constr "DIR"
configFromOptions :: ConfigFlags -> [Option] -> ConfigFlags
configFromOptions conf opts = foldr f conf opts
where
-- figure out up front if this is a user or global install
userInstall = last $ configUserInstall conf : [u | OptUserInstall u <- opts]
f o cfg = case o of
OptCompilerFlavor c -> cfg { configCompiler = c}
OptCompiler p -> cfg { configCompilerPath = Just p }
OptHcPkg p -> cfg { configHcPkgPath = Just p }
OptConfigFile _ -> cfg
OptCacheDir d -> cfg { configCacheDir = d }
OptPrefix d -> lib (\ds x -> ds { prefixDirTemplate = x }) d
OptBinDir d -> lib (\ds x -> ds { binDirTemplate = x }) d
OptLibDir d -> lib (\ds x -> ds { libDirTemplate = x }) d
OptLibSubDir d -> lib (\ds x -> ds { libSubdirTemplate = x }) d
OptLibExecDir d -> lib (\ds x -> ds { libexecDirTemplate = x }) d
OptDataDir d -> lib (\ds x -> ds { dataDirTemplate = x }) d
OptDataSubDir d -> lib (\ds x -> ds { dataSubdirTemplate = x }) d
OptDocDir d -> lib (\ds x -> ds { docDirTemplate = x }) d
OptHtmlDir d -> lib (\ds x -> ds { htmlDirTemplate = x }) d
OptUserInstall u -> cfg { configUserInstall = u }
OptHelp -> error "Got to setFlagsFromOptions OptHelp"
OptVerbose v -> cfg { configVerbose = v }
where
-- This is a bit of a hack to allow just one set of installdir command-line
-- options. Settings on the comman-line are for a single install session only,
-- which will be either a user or global install.
lib g d | userInstall = cfg { configUserInstallDirs = g (configUserInstallDirs cfg) d' }
| otherwise = cfg { configGlobalInstallDirs = g (configGlobalInstallDirs cfg) d' }
where d' = toPathTemplate d
data Cmd = Cmd {
cmdName :: String,
cmdHelp :: String, -- Short description
cmdDescription :: String, -- Long description
cmdOptions :: [OptDescr Option],
cmdAction :: Action
}
commandList :: [Cmd]
commandList = [fetchCmd, installCmd, updateCmd, cleanCmd, listCmd, infoCmd]
lookupCommand :: String -> Maybe Cmd
lookupCommand name = find ((==name) . cmdName) commandList
printGlobalHelp :: IO ()
printGlobalHelp = do pname <- getProgName
let syntax_line = concat [ "Usage: ", pname
, " [GLOBAL FLAGS]\n or: ", pname
, " COMMAND [FLAGS]\n\nGlobal flags:"]
putStrLn (usageInfo syntax_line globalOptions)
putStrLn "Commands:"
let maxlen = maximum [ length (cmdName cmd) | cmd <- commandList ]
sequence_ [ do putStr " "
putStr (align maxlen (cmdName cmd))
putStr " "
putStrLn (cmdHelp cmd)
| cmd <- commandList ]
where align n str = str ++ replicate (n - length str) ' '
parseGlobalArgs :: [String] -> IO (Action,[Option],[String])
parseGlobalArgs opts =
do let (flags, args, unrec, errs) = getOpt' RequireOrder globalOptions opts
when (OptHelp `elem` flags) $
do printGlobalHelp
exitWith ExitSuccess
when (not (null errs)) $
do putStrLn "Errors:"
mapM_ putStrLn errs
exitWith (ExitFailure 1)
when (not (null unrec)) $
do putStrLn "Unrecognized options:"
mapM_ putStrLn unrec
exitWith (ExitFailure 1)
case args of
[] -> do putStrLn $ "No command given (try --help)"
exitWith (ExitFailure 1)
cname:cargs -> case lookupCommand cname of
Just cmd -> return (cmdAction cmd, flags, cargs)
Nothing -> do putStrLn $ "Unrecognised command: " ++ cname ++ " (try --help)"
exitWith (ExitFailure 1)
mkCmd :: String -> String -> String -> Action -> Cmd
mkCmd name help desc action =
Cmd { cmdName = name
, cmdHelp = help
, cmdDescription = desc
, cmdOptions = []
, cmdAction = action
}