cab-0.1.8: CmdDB.hs
module CmdDB where
import Commands
import Control.Monad
import Data.List
import Program
import System.Console.GetOpt
import System.Exit
import System.IO
import Types
import Utils
----------------------------------------------------------------
commandDB :: CommandDB
commandDB = [
CommandSpec {
command = Sync
, commandNames = ["sync", "update"]
, document = "Fetch the latest package index"
, routing = RouteCabal ["update"]
, switches = []
, manual = Nothing
}
, CommandSpec {
command = Install
, commandNames = ["install"]
, document = "Install packages"
, routing = RouteCabal ["install"]
, switches = [(SwNoharm, Just "--dry-run -v")
-- FIXME cabal-dev not support --dry-run
,(SwSandbox, Just "--sandbox")
,(SwFlag, Just "--flags")
]
, manual = Just "[<package> [<ver>]]"
}
, CommandSpec {
command = Uninstall
, commandNames = ["uninstall", "delete", "remove", "unregister"]
, document = "Uninstall packages"
, routing = RouteFunc uninstall
, switches = [(SwNoharm, Nothing)
,(SwRecursive, Nothing)
,(SwSandbox, Just "--sandbox")
] -- don't allow SwAll
, manual = Just "<package> [<ver>]"
}
, CommandSpec {
command = Installed
, commandNames = ["installed", "list"]
, document = "List installed packages"
, routing = RouteFunc installed
, switches = [(SwAll, Nothing)
,(SwRecursive, Nothing)
,(SwInfo, Nothing)
,(SwSandbox, Just "--sandbox")
]
, manual = Nothing
}
, CommandSpec {
command = Configure
, commandNames = ["configure", "conf"]
, document = "Configure a cabal package"
, routing = RouteCabal ["configure"]
, switches = [(SwSandbox, Just "--sandbox")
,(SwFlag, Just "--flags")]
, manual = Nothing
}
, CommandSpec {
command = Build
, commandNames = ["build"]
, document = "Build a cabal package"
, routing = RouteCabal ["build"]
, switches = []
, manual = Nothing
}
, CommandSpec {
command = Clean
, commandNames = ["clean"]
, document = "Clean up a build directory"
, routing = RouteCabal ["clean"]
, switches = []
, manual = Nothing
}
, CommandSpec {
command = Outdated
, commandNames = ["outdated"]
, document = "Display outdated packages"
, routing = RouteFunc outdated
, switches = [(SwAll, Nothing)
,(SwSandbox, Just "--sandbox")]
, manual = Nothing
}
, CommandSpec {
command = Info
, commandNames = ["info"]
, document = "Display information of a package"
, routing = RouteCabal ["info"]
, switches = [(SwSandbox, Just "--sandbox")]
, manual = Just "<package> [<ver>]"
}
, CommandSpec {
command = Sdist
, commandNames = ["sdist", "pack"]
, document = "Make tar.gz for source distribution"
, routing = RouteCabal ["sdist"]
, switches = []
, manual = Nothing
}
, CommandSpec {
command = Upload
, commandNames = ["upload", "up"]
, document = "Uploading tar.gz to HackageDB"
, routing = RouteCabal ["upload"]
, switches = [(SwNoharm, Just "-c")]
, manual = Nothing
}
, CommandSpec {
command = Unpack
, commandNames = ["unpack"]
, document = "Untar a package in the current directory"
, routing = RouteCabal ["unpack"]
, switches = []
, manual = Just "<package> [<ver>]"
}
, CommandSpec {
command = Deps
, commandNames = ["deps"]
, document = "Show dependencies of this package"
, routing = RouteFunc deps
, switches = [(SwRecursive, Nothing)
,(SwAll, Nothing)
,(SwInfo, Nothing)
,(SwSandbox, Just "--sandbox")
]
, manual = Just "<package> [<ver>]"
}
, CommandSpec {
command = RevDeps
, commandNames = ["revdeps", "dependents"]
, document = "Show reverse dependencies of this package"
, routing = RouteFunc revdeps
, switches = [(SwRecursive, Nothing)
,(SwAll, Nothing)
,(SwInfo, Nothing)
,(SwSandbox, Just "--sandbox")
]
, manual = Just "<package> [<ver>]"
}
, CommandSpec {
command = Check
, commandNames = ["check"]
, document = "Check consistency of packages"
, routing = RouteFunc check
, switches = [(SwSandbox, Just "--sandbox")]
, manual = Nothing
}
, CommandSpec {
command = GenPaths
, commandNames = ["genpaths", "genpath"]
, document = "Generate Paths_<pkg>.hs"
, routing = RouteFunc genpaths
, switches = []
, manual = Nothing
}
, CommandSpec {
command = Search
, commandNames = ["search"]
, document = "Search available packages by package name"
, routing = RouteFunc search
, switches = []
, manual = Just "<key>"
}
, CommandSpec {
command = Env
, commandNames = ["env"]
, document = "Show environment variables"
, routing = RouteFunc env
, switches = [(SwSandbox, Just "--sandbox")]
, manual = Nothing
}
, CommandSpec {
command = Add
, commandNames = ["add", "add-source"]
, document = "Add a source directory"
, routing = RouteFunc add
, switches = [(SwSandbox, Just "--sandbox")]
, manual = Just "<source>"
}
, CommandSpec {
command = Help
, commandNames = ["help"]
, document = "Display the help message of the command"
, routing = RouteFunc helpCommandAndExit
, switches = []
, manual = Just "[<command>]"
}
]
----------------------------------------------------------------
commandSpecByName :: String -> CommandDB -> Maybe CommandSpec
commandSpecByName _ [] = Nothing
commandSpecByName x (ent:ents)
| x `elem` commandNames ent = Just ent
| otherwise = commandSpecByName x ents
----------------------------------------------------------------
getOptDB :: GetOptDB
getOptDB = [
Option ['n'] ["dry-run"]
(NoArg OptNoharm)
"Run without destructive operations"
, Option ['r'] ["recursive"]
(NoArg OptRecursive)
"Follow dependencies recursively"
, Option ['a'] ["all"]
(NoArg OptAll)
"Show global packages in addition to user packages"
, Option ['i'] ["info"]
(NoArg OptInfo)
"Show license and author information"
, Option ['s'] ["sandbox"]
(ReqArg OptSandbox "<sandbox>")
"Specify a sandbox directory"
, Option ['f'] ["flags"]
(ReqArg OptFlag "<flags>")
"Specify flags"
, Option ['h'] ["help"]
(NoArg OptHelp)
"Show help message"
]
optionDB :: OptionDB
optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwSandbox,SwFlag] getOptDB
----------------------------------------------------------------
optionName :: OptionSpec -> String
optionName (_,Option (c:_) _ (ReqArg _ arg) _) = '-':c:' ':arg
optionName (_,Option (c:_) _ _ _) = '-':[c]
optionName _ = ""
optionNames :: OptionSpec -> [String]
optionNames (_,Option (c:_) (s:_) _ _) = ['-':[c],'-':'-':s]
optionNames _ = []
optionDesc :: OptionSpec -> String
optionDesc (_,Option _ _ _ desc) = desc
getOptNames :: GetOptSpec -> (String,String)
getOptNames (Option (c:_) (s:_) _ _) = ('-':[c],'-':'-':s)
getOptNames _ = error "getOptNames"
resolveOptionString :: [Arg] -> Switch -> [UnknownOpt]
resolveOptionString oargs sw = case lookup sw optionDB of
Nothing -> error "resolveOptionString"
Just gspec -> let (s,l) = getOptNames gspec
in checkShort s ++ checkLong l
where
checkShort s = filter (==s) oargs
checkLong l = filter (l `isPrefixOf`) oargs
optionsToString :: [Option] -> SwitchDB -> [String]
optionsToString opts swdb = concatMap suboption opts
where
suboption opt = case lookup (toSwitch opt) swdb of
Nothing -> []
Just Nothing -> []
Just (Just x) -> case opt of
OptSandbox dir -> [x++"="++dir]
OptFlag flags -> [x++"="++flags]
_ -> [x]
----------------------------------------------------------------
helpCommandAndExit :: FunctionCommand
helpCommandAndExit _ [] _ = helpAndExit
helpCommandAndExit _ (cmd:_) _ = do
case mcmdspec of
Nothing -> helpAndExit
Just cmdspec -> do
putStrLn $ "Usage: " ++ cmd ++ " " ++ showOptions cmdspec ++ showArgs cmdspec
putStr "\n"
putStrLn $ document cmdspec
putStr "\n"
putStrLn $ "Aliases: " ++ showAliases cmdspec
putStr "\n"
printOptions cmdspec
exitSuccess
where
mcmdspec = commandSpecByName cmd commandDB
showOptions cmdspec = "[" ++ joinBy "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]"
showArgs cmdspec = maybe "" (" " ++) $ manual cmdspec
opts = map fst . switches
masterOption [] _ = []
masterOption (spec:specs) o
| fst spec == o = optionName spec : masterOption specs o
| otherwise = masterOption specs o
showAliases = joinBy ", " . commandNames
printOptions :: CommandSpec -> IO ()
printOptions cmdspec =
forM_ opts (printOption optionDB)
where
opts = map fst $ switches cmdspec
printOption [] _ = return ()
printOption (spec:specs) o
| fst spec == o =
putStrLn $ (joinBy ", " . reverse . optionNames $ spec)
++ "\t" ++ optionDesc spec
| otherwise = printOption specs o
----------------------------------------------------------------
helpAndExit :: IO ()
helpAndExit = do
putStrLn $ programName ++ " " ++ " -- " ++ description
putStrLn ""
putStrLn $ "Version: " ++ showVersion version
putStrLn "Usage:"
putStrLn $ "\t" ++ programName
putStrLn $ "\t" ++ programName ++ " <command> [args...]"
putStrLn "\t where"
printCommands (getCommands commandDB)
exitSuccess
where
getCommands = map concat
. split helpCommandNumber
. intersperse ", "
. map (head . commandNames)
printCommands [] = return ()
printCommands (x:xs) = do
putStrLn $ "\t <command> = " ++ x
mapM_ (\cmds -> putStrLn $ "\t " ++ cmds) xs
helpCommandNumber :: Int
helpCommandNumber = 10
----------------------------------------------------------------
illegalCommandAndExit :: String -> IO ()
illegalCommandAndExit x = do
hPutStrLn stderr $ "Illegal command: " ++ x
exitFailure
----------------------------------------------------------------
illegalOptionsAndExit :: [UnknownOpt] -> IO ()
illegalOptionsAndExit xs = do -- FixME
hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs
exitFailure