-----------------------------------------------------------------------------
-- |
-- Module : Hackage.Setup
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
--
-----------------------------------------------------------------------------
module Hackage.Setup
( parsePackageArgs
, parseGlobalArgs
, configFromOptions
) 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 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
}
fetchCmd :: Cmd
fetchCmd = mkCmd "fetch" "Downloads packages for later installation or study." "" FetchCmd
installCmd :: Cmd
installCmd = mkCmd "install" "Installs a list of packages." "" InstallCmd
listCmd :: Cmd
listCmd = mkCmd "list" "List available packages on the server." "" ListCmd
updateCmd :: Cmd
updateCmd = mkCmd "update" "Updates list of known packages" "" UpdateCmd
cleanCmd :: Cmd
cleanCmd = mkCmd "clean" "Removes downloaded files" "" CleanCmd
infoCmd :: Cmd
infoCmd = mkCmd "info" "Emit some info"
"Emits information about dependency resolution" InfoCmd
parsePackageArgs :: Action -> [String] -> IO ([String],[UnresolvedDependency])
parsePackageArgs _ args
= return (globalArgs,parsePkgArgs pkgs)
where (globalArgs,pkgs) = break (not.(==)'-'.head) args
parseDep dep
= case readPToMaybe parseDependencyOrPackageId dep of
Nothing -> error ("Failed to parse package dependency: " ++ show dep)
Just x -> x
parsePkgArgs [] = []
parsePkgArgs (x:xs)
= let (args',rest) = break (not.(==) '-'.head) xs
in (UnresolvedDependency
{ dependency = parseDep x
, depOptions = args' }
):parsePkgArgs rest