cab 0.1.15 → 0.2.0
raw patch · 27 files changed
+1406/−1186 lines, 27 filesdep +cabdep ~Cabal
Dependencies added: cab
Dependency ranges changed: Cabal
Files
- CmdDB.hs +0/−394
- Commands.hs +0/−202
- Distribution/Cab.hs +23/−0
- Distribution/Cab/Commands.hs +192/−0
- Distribution/Cab/GenPaths.hs +53/−0
- Distribution/Cab/PkgDB.hs +127/−0
- Distribution/Cab/Printer.hs +91/−0
- Distribution/Cab/Sandbox.hs +91/−0
- Distribution/Cab/Utils.hs +33/−0
- Distribution/Cab/VerDB.hs +90/−0
- Distribution/Cab/Version.hs +43/−0
- Env.hs +0/−10
- GenPaths.hs +0/−53
- Main.hs +0/−93
- PkgDB.hs +0/−196
- Program.hs +0/−13
- Types.hs +0/−122
- Utils.hs +0/−21
- VerDB.hs +0/−72
- cab.cabal +43/−10
- src/Commands.hs +235/−0
- src/Help.hs +111/−0
- src/Help.hs-boot +5/−0
- src/Main.hs +104/−0
- src/Options.hs +51/−0
- src/Program.hs +13/−0
- src/Types.hs +101/−0
− CmdDB.hs
@@ -1,394 +0,0 @@-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")- ,(SwTest, Just "--enable-tests")- ,(SwBench, Just "--enable-benchmarks")- ]- , 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 = Test- , commandNames = ["test"]- , document = "Run tests"- , routing = RouteCabal ["test"]- , switches = [(SwSandbox, Just "--sandbox")]- , manual = Nothing- }- , CommandSpec {- command = Bench- , commandNames = ["bench"]- , document = "Run benchmarks"- , routing = RouteCabal ["bench"]- , switches = [(SwSandbox, Just "--sandbox")]- , manual = Nothing- }- , CommandSpec {- command = Doc- , commandNames = ["doc", "haddock", "man"]- , document = "Generate manuals"- , routing = RouteCabal ["haddock", "--hyperlink-source"]- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Ghci- , commandNames = ["ghci"]- , document = "Run GHCi within a sandbox"- , routing = RouteFunc ghci- , switches = [(SwSandbox, Just "--sandbox")]- , manual = Nothing- }- , 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 ['t'] ["test"]- (NoArg OptTest)- "Enable test"- , Option ['b'] ["bench"]- (NoArg OptBench)- "Enable benchmark"- , Option ['h'] ["help"]- (NoArg OptHelp)- "Show help message"- ]--optionDB :: OptionDB-optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwSandbox,SwFlag,SwTest,SwBench] 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
− Commands.hs
@@ -1,202 +0,0 @@-module Commands (- deps, revdeps, installed, outdated, uninstall, search, env- , genpaths, check, add, ghci- ) where--import Control.Applicative hiding (many)-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import GenPaths-import PkgDB-import System.Exit-import System.IO-import System.Process hiding (env)-import Types-import Utils-import VerDB--------------------------------------------------------------------search :: FunctionCommand-search _ [x] _ = do- nvls <- getVerAlist False- forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ toDotted v- where- key = map toLower x- sat (n,_) = key `isPrefixOf` map toLower n- lok [] = []- lok (e:es)- | sat e = e : lok es- | otherwise = lok es-search _ _ _ = do- hPutStrLn stderr "One search-key should be specified."- exitFailure--------------------------------------------------------------------installed :: FunctionCommand-installed _ _ opts = do- let optall = OptAll `elem` opts- optrec = OptRecursive `elem` opts- db' <- getPkgDB (getSandbox opts)- flt <- if optall then allPkgs else userPkgs- -- FIXME: the optall case does unnecessary conversion- let pkgs = toPkgList flt db'- db = toPkgDB pkgs- forM_ pkgs $ \pkgi -> do- putStr $ fullNameOfPkgInfo pkgi- extraInfo info pkgi- putStrLn ""- when optrec $ printDeps True info db 1 pkgi- where- info = OptInfo `elem` opts--outdated :: FunctionCommand-outdated _ _ opts = do- flt <- if OptAll `elem` opts then allPkgs else userPkgs- pkgs <- toPkgList flt <$> getPkgDB (getSandbox opts)- verDB <- getVerDB- forM_ pkgs $ \p -> case lookupLatestVersion (nameOfPkgInfo p) verDB of- Nothing -> return ()- Just ver -> when (numVersionOfPkgInfo p /= ver) $- putStrLn $ fullNameOfPkgInfo p ++ " < " ++ toDotted ver--------------------------------------------------------------------uninstall :: FunctionCommand-uninstall _ nmver opts = do- db' <- getPkgDB (getSandbox opts)- db <- toPkgDB . flip toPkgList db' <$> userPkgs- pkg <- lookupPkg nmver db- let sortedPkgs = topSortedPkgs pkg db- if onlyOne && length sortedPkgs /= 1 then do- hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option."- mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs)- else do- unless doit $ putStrLn "The following packages are deleted without the \"-n\" option."- mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs- where- onlyOne = OptRecursive `notElem` opts- doit = OptNoharm `notElem` opts--unregister :: Bool -> [Option] -> (String,String) -> IO ()-unregister doit opts (name,ver) =- if doit then do- putStrLn $ "Deleting " ++ name ++ " " ++ ver- pkgconf <- pkgConfOpt opts- when doit $ void . system $ script pkgconf- else- putStrLn $ name ++ " " ++ ver- where- script pkgconf = "ghc-pkg unregister " ++ pkgconf ++ name ++ "-" ++ ver--pkgConfOpt :: [Option] -> IO String-pkgConfOpt opts = case getSandbox opts of- Nothing -> return ""- Just path -> do- pkgConf <- getPackageConf path- return $ "--package-conf=" ++ pkgConf ++ " "--------------------------------------------------------------------genpaths :: FunctionCommand-genpaths _ _ _ = genPaths--------------------------------------------------------------------check :: FunctionCommand-check _ _ opts = do- pkgconf <- pkgConfOpt opts- void . system $ script pkgconf- where- script pkgconf = "ghc-pkg check -v " ++ pkgconf--------------------------------------------------------------------deps :: FunctionCommand-deps _ nmver opts = printDepends nmver opts printDeps--revdeps :: FunctionCommand-revdeps _ nmver opts = printDepends nmver opts printRevDeps--printDepends :: [String] -> [Option]- -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()-printDepends nmver opts func = do- db' <- getPkgDB (getSandbox opts)- pkg <- lookupPkg nmver db'- db <- if OptAll `elem` opts- then return db'- else toPkgDB . flip toPkgList db' <$> userPkgs- func rec info db 0 pkg- where- rec = OptRecursive `elem` opts- info = OptInfo `elem` opts--------------------------------------------------------------------lookupPkg :: [String] -> PkgDB -> IO PkgInfo-lookupPkg [] _ = do- hPutStrLn stderr "Package name must be specified."- exitFailure-lookupPkg [name] db = checkOne $ lookupByName name db-lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db-lookupPkg _ _ = do- hPutStrLn stderr "Only one package name must be specified."- exitFailure--checkOne :: [PkgInfo] -> IO PkgInfo-checkOne [] = do- hPutStrLn stderr "No such package found."- exitFailure-checkOne [pkg] = return pkg-checkOne pkgs = do- hPutStrLn stderr "Package version must be specified."- mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs- exitFailure--------------------------------------------------------------------env :: FunctionCommand-env _ _ opts = case getSandbox opts of- Nothing -> do- putStrLn "unset CAB_SANDBOX_PATH"- putStrLn "unsetenv CAB_SANDBOX_PATH"- putStrLn ""- putStrLn "unset GHC_PACKAGE_PATH"- putStrLn "unsetenv GHC_PACKAGE_PATH"- Just path -> do- pkgConf <- getPackageConf path- gPkgConf <- globalPackageDB- putStrLn $ "export CAB_SANDBOX_PATH=" ++ path- putStrLn $ "setenv CAB_SANDBOX_PATH " ++ path- putStrLn ""- putStrLn "The following commands are not necessary in normal case."- let confs = gPkgConf ++ ":" ++ pkgConf- putStrLn $ "export GHC_PACKAGE_PATH=" ++ confs- putStrLn $ "setenv GHC_PACKAGE_PATH " ++ confs--globalPackageDB :: IO String-globalPackageDB = do- res <- readProcess "ghc" ["--info"] []- let alist = read res :: [(String,String)]- return . fromJust $ lookup "Global Package DB" alist--------------------------------------------------------------------add :: FunctionCommand-add _ params opts = case getSandbox opts of- Nothing -> hPutStrLn stderr "A sandbox must be specified with \"-s\" option."- Just sbox -> case params of- [src] -> void . system $ "cabal-dev add-source " ++ src ++ " -s " ++ sbox- _ -> hPutStrLn stderr "A source path be specified."--------------------------------------------------------------------ghci :: FunctionCommand-ghci _ _ opts = case getSandbox opts of- Nothing -> hPutStrLn stderr "A sandbox must be specified with \"-s\" option."- Just sbox -> do- _ <- system $ "cabal-dev -s " ++ sbox ++ " ghci"- return ()
+ Distribution/Cab.hs view
@@ -0,0 +1,23 @@+module Distribution.Cab (+ -- * Types+ Option(..)+ , FunctionCommand+ -- * Commands+ , deps+ , revdeps+ , installed+ , outdated+ , uninstall+ , search+ , genpaths+ , check+ , add+ , initSandbox+ , ghci+ -- * Utilities+ , joinBy+ , split+ ) where++import Distribution.Cab.Commands+import Distribution.Cab.Utils
+ Distribution/Cab/Commands.hs view
@@ -0,0 +1,192 @@+module Distribution.Cab.Commands (+ FunctionCommand+ , Option(..)+ , deps, revdeps, installed, outdated, uninstall, search+ , genpaths, check, initSandbox, add, ghci+ ) where++import Control.Applicative hiding (many)+import Control.Monad+import Data.Char+import Data.List+import qualified Data.Map as M+import Distribution.Cab.GenPaths+import Distribution.Cab.PkgDB+import Distribution.Cab.Printer+import Distribution.Cab.Sandbox+import Distribution.Cab.VerDB+import Distribution.Cab.Version+import Distribution.Cab.Utils+import System.Exit+import System.IO+import System.Process hiding (env)++----------------------------------------------------------------++type FunctionCommand = [String] -> [Option] -> IO ()++data Option = OptNoharm+ | OptRecursive+ | OptAll+ | OptInfo+ | OptFlag String+ | OptTest+ | OptHelp+ | OptBench+ | OptDepsOnly+ | OptLibProfile+ | OptExecProfile+ | OptJobs String+ deriving (Eq,Show)++----------------------------------------------------------------++search :: FunctionCommand+search [x] _ = do+ nvls <- toList <$> getVerDB AllRegistered+ forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ verToString v+ where+ key = map toLower x+ sat (n,_) = key `isPrefixOf` map toLower n+ lok = filter sat+search _ _ = do+ hPutStrLn stderr "One search-key should be specified."+ exitFailure++----------------------------------------------------------------++installed :: FunctionCommand+installed _ opts = do+ db <- getDB opts+ let pkgs = toPkgInfos db+ forM_ pkgs $ \pkgi -> do+ putStr $ fullNameOfPkgInfo pkgi+ extraInfo info pkgi+ putStrLn ""+ when optrec $ printDeps True info db 1 pkgi+ where+ info = OptInfo `elem` opts+ optrec = OptRecursive `elem` opts++outdated :: FunctionCommand+outdated _ opts = do+ pkgs <- toPkgInfos <$> getDB opts+ verDB <- toMap <$> getVerDB InstalledOnly+ forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of+ Nothing -> return ()+ Just ver -> when (verOfPkgInfo p /= ver) $+ putStrLn $ fullNameOfPkgInfo p ++ " < " ++ verToString ver++getDB :: [Option] -> IO PkgDB+getDB opts+ | optall = getSandbox >>= getPkgDB+ | otherwise = getSandbox >>= getUserPkgDB+ where+ optall = OptAll `elem` opts++----------------------------------------------------------------++uninstall :: FunctionCommand+uninstall nmver opts = do+ userDB <- getSandbox >>= getUserPkgDB+ pkg <- lookupPkg nmver userDB+ let sortedPkgs = topSortedPkgs pkg userDB+ if onlyOne && length sortedPkgs /= 1 then do+ hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option."+ mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs)+ else do+ unless doit $ putStrLn "The following packages are deleted without the \"-n\" option."+ mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs+ where+ onlyOne = OptRecursive `notElem` opts+ doit = OptNoharm `notElem` opts++unregister :: Bool -> [Option] -> (String,String) -> IO ()+unregister doit _ (name,ver) =+ if doit then do+ putStrLn $ "Deleting " ++ name ++ " " ++ ver+ sandboxOpts <- getSandboxOpts <$> getSandbox+ when doit $ void . system $ script sandboxOpts+ else+ putStrLn $ name ++ " " ++ ver+ where+ script sandboxOpts = "ghc-pkg unregister " ++ sandboxOpts ++ " " ++ name ++ "-" ++ ver++----------------------------------------------------------------++genpaths :: FunctionCommand+genpaths _ _ = genPaths++----------------------------------------------------------------++check :: FunctionCommand+check _ _ = do+ sandboxOpts <- getSandboxOpts <$> getSandbox+ void . system $ script sandboxOpts+ where+ script sandboxOpts = "ghc-pkg check -v " ++ sandboxOpts++----------------------------------------------------------------++deps :: FunctionCommand+deps nmver opts = printDepends nmver opts printDeps++revdeps :: FunctionCommand+revdeps nmver opts = printDepends nmver opts printRevDeps++printDepends :: [String] -> [Option]+ -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()+printDepends nmver opts func = do+ db' <- getSandbox >>= getPkgDB+ pkg <- lookupPkg nmver db'+ db <- getDB opts+ func rec info db 0 pkg+ where+ rec = OptRecursive `elem` opts+ info = OptInfo `elem` opts++----------------------------------------------------------------++lookupPkg :: [String] -> PkgDB -> IO PkgInfo+lookupPkg [] _ = do+ hPutStrLn stderr "Package name must be specified."+ exitFailure+lookupPkg [name] db = checkOne $ lookupByName name db+lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db+lookupPkg _ _ = do+ hPutStrLn stderr "Only one package name must be specified."+ exitFailure++checkOne :: [PkgInfo] -> IO PkgInfo+checkOne [] = do+ hPutStrLn stderr "No such package found."+ exitFailure+checkOne [pkg] = return pkg+checkOne pkgs = do+ hPutStrLn stderr "Package version must be specified."+ mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs+ exitFailure++----------------------------------------------------------------++initSandbox :: FunctionCommand+initSandbox [] _ = void . system $ "cabal sandbox init"+initSandbox [path] _ = void . system $ "cabal sandbox init --sandbox " ++ path+initSandbox _ _ = do+ hPutStrLn stderr "Only one argument is allowed"+ exitFailure++----------------------------------------------------------------++add :: FunctionCommand+add [src] _ = void . system $ "cabal sandbox add-source " ++ src+add _ _ = do+ hPutStrLn stderr "A source path be specified."+ exitFailure++----------------------------------------------------------------++ghci :: FunctionCommand+ghci args _ = do+ opts <- getSandboxOpts <$> getSandbox+ void $ system $ "ghci" ++ " " ++ opts ++ " " ++ joinBy " " args
+ Distribution/Cab/GenPaths.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module Distribution.Cab.GenPaths (genPaths) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.List (isSuffixOf)+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Verbosity (silent)+import Distribution.Version+import System.Directory++genPaths :: IO ()+genPaths = do+ (nm,ver) <- getCabalFile >>= getNameVersion+ let file = "Paths_" ++ nm ++ ".hs"+ check file >> do+ putStrLn $ "Writing " ++ file ++ "..."+ writeFile file $ "module Paths_" ++ nm ++ " where\n"+ ++ "import Data.Version\n"+ ++ "\n"+ ++ "version :: Version\n"+ ++ "version = " ++ show ver ++ "\n"+ where+ check file = do+ exist <- doesFileExist file+ when exist . throwIO . userError $ file ++ " already exists"++getNameVersion :: FilePath -> IO (String,Version)+getNameVersion file = do+ desc <- readPackageDescription silent file+ let pkg = package . packageDescription $ desc+ PackageName nm = pkgName pkg+ name = map (trans '-' '_') nm+ version = pkgVersion pkg+ return (name, version)+ where+ trans c1 c2 c+ | c == c1 = c2+ | otherwise = c++getCabalFile :: IO FilePath+getCabalFile = do+ cnts <- (filter isCabal <$> getDirectoryContents ".")+ >>= filterM doesFileExist+ case cnts of+ [] -> throwIO $ userError "Cabal file does not exist"+ cfile:_ -> return cfile+ where+ isCabal nm = ".cabal" `isSuffixOf` nm && length nm > 6
+ Distribution/Cab/PkgDB.hs view
@@ -0,0 +1,127 @@+module Distribution.Cab.PkgDB (+ -- * Types+ PkgDB+ , PkgInfo+ -- * Obtaining 'PkgDB'+ , getPkgDB+ , getGlobalPkgDB+ , getUserPkgDB+ -- * Looking up+ , lookupByName+ , lookupByVersion+ -- * Topological sorting+ , topSortedPkgs+ -- * To 'PkgInfo'+ , toPkgInfos+ -- * From 'PkgInfo'+ , nameOfPkgInfo+ , fullNameOfPkgInfo+ , pairNameOfPkgInfo+ , verOfPkgInfo+ ) where++import Distribution.Cab.Utils (fromDotted)+import Distribution.Cab.Version+import Distribution.Cab.VerDB (PkgName)+import Distribution.Version (Version(..))+import Distribution.InstalledPackageInfo+ (InstalledPackageInfo_(..), InstalledPackageInfo)+import Distribution.Package (PackageName(..), PackageIdentifier(..))+import Distribution.Simple.Compiler (PackageDB(..))+import Distribution.Simple.GHC (configure, getInstalledPackages, getPackageDBContents)+import Distribution.Simple.PackageIndex+ (lookupPackageName, lookupSourcePackageId+ , allPackages, fromList, reverseDependencyClosure+ , topologicalOrder, PackageIndex)+import Distribution.Simple.Program.Db (defaultProgramDb)+import Distribution.Verbosity (normal)++type PkgDB = PackageIndex+type PkgInfo = InstalledPackageInfo++----------------------------------------------------------------++-- | Obtaining 'PkgDB' for global and user+--+-- > getSandbox >>= getPkgDB+getPkgDB :: Maybe FilePath -> IO PkgDB+getPkgDB mpath = getDBs [GlobalPackageDB,userDB]+ where+ userDB = toUserSpec mpath++-- | Obtaining 'PkgDB' for user+getUserPkgDB :: Maybe FilePath -> IO PkgDB+getUserPkgDB mpath = getDB userDB+ where+ userDB = toUserSpec mpath++-- | Obtaining 'PkgDB' for global+getGlobalPkgDB :: IO PkgDB+getGlobalPkgDB = getDB GlobalPackageDB++toUserSpec :: Maybe FilePath -> PackageDB+toUserSpec Nothing = UserPackageDB+toUserSpec (Just path) = SpecificPackageDB path++getDBs :: [PackageDB] -> IO PackageIndex+getDBs specs = do+ (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb+ getInstalledPackages normal specs pro++getDB :: PackageDB -> IO PackageIndex+getDB spec = do+ (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb+ getPackageDBContents normal spec pro++----------------------------------------------------------------++-- |+--+-- > pkgdb <- getGlobalPkgDB+-- > lookupByName "base" pkgdb+lookupByName :: PkgName -> PkgDB -> [PkgInfo]+lookupByName name db = concatMap snd $ lookupPackageName db (PackageName name)++-- |+--+-- > pkgdb <- getGlobalPkgDB+-- > lookupByVersion "base" "4.6.0.1" pkgdb+lookupByVersion :: PkgName -> String -> PkgDB -> [PkgInfo]+lookupByVersion name ver db = lookupSourcePackageId db src+ where+ src = PackageIdentifier {+ pkgName = PackageName name+ , pkgVersion = Version {+ versionBranch = fromDotted ver+ , versionTags = []+ }+ }++----------------------------------------------------------------++toPkgInfos :: PkgDB -> [PkgInfo]+toPkgInfos db = allPackages db++----------------------------------------------------------------++nameOfPkgInfo :: PkgInfo -> PkgName+nameOfPkgInfo = toString . pkgName . sourcePackageId+ where+ toString (PackageName x) = x++fullNameOfPkgInfo :: PkgInfo -> String+fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ verToString (verOfPkgInfo pkgi)++pairNameOfPkgInfo :: PkgInfo -> (PkgName,String)+pairNameOfPkgInfo pkgi = (nameOfPkgInfo pkgi, verToString (verOfPkgInfo pkgi))++verOfPkgInfo :: PkgInfo -> Ver+verOfPkgInfo = version . pkgVersion . sourcePackageId++----------------------------------------------------------------++topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo]+topSortedPkgs pkgi db = topSort $ pkgids [pkgi]+ where+ pkgids = map installedPackageId+ topSort = topologicalOrder . fromList . reverseDependencyClosure db
+ Distribution/Cab/Printer.hs view
@@ -0,0 +1,91 @@+module Distribution.Cab.Printer (+ printDeps+ , printRevDeps+ , extraInfo+ ) where++import Control.Monad+import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Distribution.Cab.PkgDB+import Distribution.Cab.Version+import Distribution.InstalledPackageInfo (InstalledPackageInfo_(..))+import Distribution.License (License(..))+import Distribution.Package (InstalledPackageId)+import Distribution.Simple.PackageIndex (lookupInstalledPackageId, allPackages)++----------------------------------------------------------------++type RevDB = Map InstalledPackageId [InstalledPackageId]++makeRevDepDB :: PkgDB -> RevDB+makeRevDepDB db = M.fromList revdeps+ where+ pkgs = allPackages db+ deps = map idDeps pkgs+ idDeps pkg = (installedPackageId pkg, depends pkg)+ kvs = sort $ concatMap decomp deps+ decomp (k,vs) = map (\v -> (v,k)) vs+ kvss = groupBy ((==) `on` fst) kvs+ comp xs = (fst (head xs), map snd xs)+ revdeps = map comp kvss++----------------------------------------------------------------++printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()+printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi++printDep :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageId -> IO ()+printDep rec info db n pid = case lookupInstalledPackageId db pid of+ Nothing -> return ()+ Just pkgi -> do+ putStr $ prefix ++ fullNameOfPkgInfo pkgi+ extraInfo info pkgi+ putStrLn ""+ when rec $ printDeps rec info db (n+1) pkgi+ where+ prefix = replicate (n * 4) ' '++----------------------------------------------------------------++printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()+printRevDeps rec info db n pkgi = printRevDeps' rec info db revdb n pkgi+ where+ revdb = makeRevDepDB db++printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO ()+printRevDeps' rec info db revdb n pkgi = case M.lookup pkgid revdb of+ Nothing -> return ()+ Just pkgids -> mapM_ (printRevDep' rec info db revdb n) pkgids+ where+ pkgid = installedPackageId pkgi++printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO ()+printRevDep' rec info db revdb n pid = case lookupInstalledPackageId db pid of+ Nothing -> return ()+ Just pkgi -> do+ putStr $ prefix ++ fullNameOfPkgInfo pkgi+ extraInfo info pkgi+ putStrLn ""+ when rec $ printRevDeps' rec info db revdb (n+1) pkgi+ where+ prefix = replicate (n * 4) ' '++----------------------------------------------------------------++extraInfo :: Bool -> PkgInfo -> IO ()+extraInfo False _ = return ()+extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ auth ++ "\""+ where+ lcns = showLicense (license pkgi)+ auth = author pkgi++showLicense :: License -> String+showLicense (GPL (Just v)) = "GPL" ++ versionToString v+showLicense (GPL Nothing) = "GPL"+showLicense (LGPL (Just v)) = "LGPL" ++ versionToString v+showLicense (LGPL Nothing) = "LGPL"+showLicense (UnknownLicense s) = s+showLicense x = show x
+ Distribution/Cab/Sandbox.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE BangPatterns #-}++module Distribution.Cab.Sandbox (+ getSandbox+ , getSandboxOpts+ ) where++import Control.Applicative ((<$>))+import Control.Exception as E (catch, SomeException, throwIO)+import Data.Char (isSpace)+import Data.List (isPrefixOf, tails)+import System.Directory (getCurrentDirectory, doesFileExist)+import System.FilePath ((</>), takeDirectory, takeFileName)++----------------------------------------------------------------++configFile :: String+configFile = "cabal.sandbox.config"++pkgDbKey :: String+pkgDbKey = "package-db:"++pkgDbKeyLen :: Int+pkgDbKeyLen = length pkgDbKey++-- | Find a sandbox config file by tracing ancestor directories,+-- parse it and return the package db path+getSandbox :: IO (Maybe FilePath)+getSandbox = (Just <$> getPkgDb) `E.catch` handler+ where+ getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir+ handler :: SomeException -> IO (Maybe String)+ handler _ = return Nothing++-- | Find a sandbox config file by tracing ancestor directories.+-- Exception is thrown if not found+getSandboxConfigFile :: FilePath -> IO FilePath+getSandboxConfigFile dir = do+ let cfile = dir </> configFile+ exist <- doesFileExist cfile+ if exist then+ return cfile+ else do+ let dir' = takeDirectory dir+ if dir == dir' then+ throwIO $ userError "sandbox config file not found"+ else+ getSandboxConfigFile dir'++-- | Extract a package db directory from the sandbox config file.+-- Exception is thrown if the sandbox config file is broken.+getPackageDbDir :: FilePath -> IO FilePath+getPackageDbDir sconf = do+ -- Be strict to ensure that an error can be caught.+ !path <- extractValue . parse <$> readFile sconf+ return path+ where+ parse = head . filter ("package-db:" `isPrefixOf`) . lines+ extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen++----------------------------------------------------------------++-- | Generate GHC options for package db according to GHC version.+--+-- >>> getSandboxOpts Nothing+-- ""+-- >>> getSandboxOpts (Just "/path/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")+-- "-package-db /path/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"+-- >>> getSandboxOpts (Just "/path/.cabal-sandbox/i386-osx-ghc-7.4.1-packages.conf.d")+-- "-package-conf /path/.cabal-sandbox/i386-osx-ghc-7.4.1-packages.conf.d"+getSandboxOpts :: Maybe FilePath -> String+getSandboxOpts Nothing = ""+getSandboxOpts (Just path) = pkgOpt ++ path+ where+ ghcver = extractGhcVer path+ pkgOpt | ghcver >= 706 = "-package-db "+ | otherwise = "-package-conf "++-- | Extracting GHC version from the path of package db.+-- Exception is thrown if the string argument is incorrect.+--+-- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"+-- 706+extractGhcVer :: String -> Int+extractGhcVer dir = ver+ where+ file = takeFileName dir+ findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails+ (verStr1,_:left) = break (== '.') $ findVer file+ (verStr2,_) = break (== '.') left+ ver = read verStr1 * 100 + read verStr2
+ Distribution/Cab/Utils.hs view
@@ -0,0 +1,33 @@+module Distribution.Cab.Utils where++import Data.List++-- |+-- >>> fromDotted "1.2.3"+-- [1,2,3]+fromDotted :: String -> [Int]+fromDotted [] = []+fromDotted xs = case break (=='.') xs of+ (x,"") -> [read x :: Int]+ (x,_:ys) -> (read x :: Int) : fromDotted ys++-- |+-- >>> toDotted [1,2,3]+-- "1.2.3"+toDotted :: [Int] -> String+toDotted = joinBy "." . map show++-- |+-- >>> joinBy "," ["foo","bar","baz"]+-- "foo,bar,baz"+joinBy :: String -> [String] -> String+joinBy = intercalate++-- |+-- >>> split 4 "0123457689"+-- ["0123","4576","89"]+split :: Int -> [a] -> [[a]]+split _ [] = []+split n ss = x : split n rest+ where+ (x,rest) = splitAt n ss
+ Distribution/Cab/VerDB.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++module Distribution.Cab.VerDB (+ -- * Types+ PkgName+ , VerDB+ , HowToObtain(..)+ -- * Creating+ , getVerDB+ -- * Converting+ , toList+ , toMap+ ) where++import Control.Applicative+import Control.Arrow (second)+import Data.Attoparsec.ByteString.Char8+import Data.Conduit+import Data.Conduit.Attoparsec+import Data.Conduit.Process+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Distribution.Cab.Version++----------------------------------------------------------------++type PkgName = String++type VerInfo = (PkgName, Maybe [Int])++newtype VerDB = VerDB [(PkgName,Ver)] deriving (Eq, Show)++data HowToObtain = InstalledOnly | AllRegistered++----------------------------------------------------------------++getVerDB :: HowToObtain -> IO VerDB+getVerDB how = VerDB . justOnly <$> verInfos+ where+ script = case how of+ InstalledOnly -> "cabal list --installed"+ AllRegistered -> "cabal list"+ verInfos = runResourceT $ sourceCmd script $$ cabalListParser+ justOnly = map (second (toVer . fromJust)) . filter (isJust . snd)+ cabalListParser = sinkParser verinfos++----------------------------------------------------------------++-- | Converting 'VerDB' to alist.+--+-- >>> db <- getVerDB InstalledOnly+-- >>> elem "base" . map fst . toList $ db+-- True+toList :: VerDB -> [(PkgName, Ver)]+toList (VerDB alist) = alist++-- | Converting 'VerDB' to 'Map'.+toMap :: VerDB -> Map PkgName Ver+toMap (VerDB alist) = M.fromList alist++----------------------------------------------------------------++verinfos :: Parser [VerInfo]+verinfos = many1 verinfo++verinfo :: Parser VerInfo+verinfo = do+ name <- string "* " *> nonEols <* endOfLine+ synpsis+ lat <- latestLabel *> latest <* endOfLine+ _ <- many skip+ endOfLine+ return (name, lat)+ where+ latestLabel = string " Default available version: " -- cabal 0.10+ <|> string " Latest version available: " -- cabal 0.8+ skip = many1 nonEols *> endOfLine+ synpsis = string " Synopsis:" *> nonEols *> endOfLine *> more+ <|> return ()+ where+ more = () <$ many (string " " *> nonEols *> endOfLine)+ latest = Nothing <$ (char '[' *> nonEols)+ <|> Just <$> dotted++dotted :: Parser [Int]+dotted = decimal `sepBy` char '.'++nonEols :: Parser String+nonEols = many1 $ satisfy (notInClass "\r\n")
+ Distribution/Cab/Version.hs view
@@ -0,0 +1,43 @@+module Distribution.Cab.Version (+ Ver+ , toVer+ , verToString+ , version+ , versionToString+ ) where++import Distribution.Cab.Utils+import Distribution.Version (Version(..))++-- | Package version.+newtype Ver = Ver [Int] deriving (Eq,Show)++-- | Creating 'Ver'.+--+-- >>> toVer [1,2,3]+-- Ver [1,2,3]+toVer :: [Int] -> Ver+toVer is = Ver is++-- | From 'Version' to 'String'+--+-- >>> verToString $ toVer [1,2,3]+-- "1.2.3"+verToString :: Ver -> String+verToString (Ver ver) = toDotted ver++-- | From 'Version' in Cabal to 'Ver'.+--+-- >>> version $ Version [1,2,3] []+-- Ver [1,2,3]+version :: Version -> Ver+version = Ver . versionBranch++-- | From 'Version' in Cabal to 'String'.+--+-- >>> versionToString $ Version [1,2,3] []+-- "1.2.3"+versionToString :: Version -> String+versionToString = verToString . version++
− Env.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module Env (unsetEnv) where--#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-unsetEnv :: String -> IO ()-unsetEnv _ = return ()-#else-import System.Posix.Env (unsetEnv)-#endif
− GenPaths.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module GenPaths (genPaths) where--import Control.Applicative-import Control.Exception-import Control.Monad-import Data.List (isSuffixOf)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.Verbosity (silent)-import Distribution.Version-import System.Directory--genPaths :: IO ()-genPaths = do- (nm,ver) <- getCabalFile >>= getNameVersion- let file = "Paths_" ++ nm ++ ".hs"- check file >> do- putStrLn $ "Writing " ++ file ++ "..."- writeFile file $ "module Paths_" ++ nm ++ " where\n"- ++ "import Data.Version\n"- ++ "\n"- ++ "version :: Version\n"- ++ "version = " ++ show ver ++ "\n"- where- check file = do- exist <- doesFileExist file- when exist . throwIO . userError $ file ++ " already exists"--getNameVersion :: FilePath -> IO (String,Version)-getNameVersion file = do- desc <- readPackageDescription silent file- let pkg = package . packageDescription $ desc- PackageName nm = pkgName pkg- name = map (trans '-' '_') nm- version = pkgVersion pkg- return (name, version)- where- trans c1 c2 c- | c == c1 = c2- | otherwise = c--getCabalFile :: IO FilePath-getCabalFile = do- cnts <- (filter isCabal <$> getDirectoryContents ".")- >>= filterM doesFileExist- case cnts of- [] -> throwIO $ userError "Cabal file does not exist"- cfile:_ -> return cfile- where- isCabal nm = ".cabal" `isSuffixOf` nm && length nm > 6
− Main.hs
@@ -1,93 +0,0 @@-module Main where--import CmdDB-import Control.Applicative-import Control.Exception-import Control.Monad-import Data.Maybe-import Prelude hiding (catch)-import System.Cmd-import System.Console.GetOpt-import System.Environment-import System.Exit-import Env-import Types-import Utils--------------------------------------------------------------------main :: IO ()-main = flip catches handlers $ do- unsetEnv "GHC_PACKAGE_PATH"- oargs <- getArgs- let pargs = parseArgs getOptDB oargs- checkOptions1 pargs illegalOptionsAndExit- let Right (args,opts0) = pargs- when (args == []) helpAndExit- when (OptHelp `elem` opts0) $ helpCommandAndExit undefined args undefined- let opts1 = filter (/= OptHelp) opts0- act:params = args- mcmdspec = commandSpecByName act commandDB- when (isNothing mcmdspec) (illegalCommandAndExit act)- let Just cmdspec = mcmdspec- checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit- opts <- sandboxEnv cmdspec opts1- run cmdspec params opts- where- handlers = [Handler handleExit]- handleExit :: ExitCode -> IO ()- handleExit _ = return ()--------------------------------------------------------------------parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs-parseArgs db args = case getOpt' Permute db args of- (o,n,[],[]) -> Right (n,o)- (_,_,unknowns,_) -> Left unknowns--checkOptions1 :: ParsedArgs -> ([UnknownOpt] -> IO ()) -> IO ()-checkOptions1 (Left es) func = func es-checkOptions1 _ _ = return ()--checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> ([UnknownOpt] -> IO ()) -> IO ()-checkOptions2 opts cmdspec oargs func = do- let unknowns = check specified supported- when (unknowns /= []) $ func (concatMap (resolveOptionString oargs) unknowns)- where- check [] _ = []- check (x:xs) ys- | x `elem` ys = check xs ys- | otherwise = x : check xs ys- specified = map toSwitch opts- supported = map fst $ switches cmdspec--sandboxEnv :: CommandSpec -> [Option] -> IO [Option]-sandboxEnv cmdspec opts =- if hasSandboxOption cmdspec && command cmdspec /= Env- then tryEnv `catch` ignore- else return opts- where- tryEnv = (\path -> OptSandbox path : opts) <$> getEnv cabEnvVar- ignore :: SomeException -> IO [Option]- ignore _ = return opts--hasSandboxOption :: CommandSpec -> Bool-hasSandboxOption cmdspec = isJust $ lookup SwSandbox (switches cmdspec)--------------------------------------------------------------------run :: CommandSpec -> [Arg] -> [Option] -> IO ()-run cmdspec params opts = case routing cmdspec of- RouteFunc func -> func cmdspec params opts- RouteCabal subargs -> callProcess pro subargs params opts sws- where- pro = cabalCommand opts- sws = switches cmdspec--callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO ()-callProcess pro args0 args1 opts sws = void . system $ script- where- swchs = optionsToString opts sws- script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs- cat [pkg,ver] = [pkg ++ "-" ++ ver]- cat x = x
− PkgDB.hs
@@ -1,196 +0,0 @@-module PkgDB where--import Control.Monad-import Data.Function-import Data.List-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe (isNothing)-import Distribution.Compiler- (CompilerId(..))-import Distribution.License- (License(..))-import Distribution.Version- (Version(..))-import Distribution.InstalledPackageInfo- (InstalledPackageInfo_(..), InstalledPackageInfo)-import Distribution.Package- (PackageName(..), PackageIdentifier(..), InstalledPackageId)-import Distribution.Simple.Compiler- (PackageDB(..),Compiler(..))-import Distribution.Simple.GHC- (configure, getInstalledPackages)-import Distribution.Simple.PackageIndex- (lookupPackageName, lookupSourcePackageId, lookupInstalledPackageId- , allPackages, fromList, reverseDependencyClosure- , topologicalOrder, PackageIndex)-import Distribution.Simple.Program.Db- (defaultProgramDb)-import Distribution.Verbosity- (normal)-import System.FilePath-import Utils--type PkgDB = PackageIndex-type PkgInfo = InstalledPackageInfo--------------------------------------------------------------------getPkgDB :: Maybe FilePath -> IO PkgDB-getPkgDB mpath = do- (com,pro) <- configure normal Nothing Nothing defaultProgramDb- let userDB = case mpath of- Nothing -> UserPackageDB- Just path -> SpecificPackageDB $ packageConf path com- getInstalledPackages normal [GlobalPackageDB,userDB] pro--getGlobalPkgDB :: IO PkgDB-getGlobalPkgDB = do- (_,pro) <- configure normal Nothing Nothing defaultProgramDb- getInstalledPackages normal [GlobalPackageDB] pro--getPackageConf :: FilePath -> IO FilePath-getPackageConf path = do- (com,_) <- configure normal Nothing Nothing defaultProgramDb- return $ packageConf path com--packageConf :: FilePath -> Compiler -> FilePath-packageConf path com = path </> "packages-" ++ version ver ++ ".conf"- where- CompilerId _ ver = compilerId com--toPkgDB :: [PkgInfo] -> PkgDB-toPkgDB = fromList--version :: Version -> String-version = toDotted . versionBranch--------------------------------------------------------------------lookupByName :: String -> PkgDB -> [PkgInfo]-lookupByName name db = concatMap snd $ lookupPackageName db (PackageName name)--lookupByVersion :: String -> String -> PkgDB -> [PkgInfo]-lookupByVersion name ver db = lookupSourcePackageId db src- where- src = PackageIdentifier {- pkgName = PackageName name- , pkgVersion = Version {- versionBranch = fromDotted ver- , versionTags = []- }- }--------------------------------------------------------------------toPkgList :: (PkgInfo -> Bool) -> PkgDB -> [PkgInfo]-toPkgList prd db = filter prd $ allPackages db--userPkgs :: IO (PkgInfo -> Bool)-userPkgs = do- gDB <- getGlobalPkgDB- return$ \pkgi -> isNothing$ lookupInstalledPackageId gDB (installedPackageId pkgi)--allPkgs :: IO (PkgInfo -> Bool)-allPkgs = return (const True)--------------------------------------------------------------------fullNameOfPkgInfo :: PkgInfo -> String-fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ versionOfPkgInfo pkgi--pairNameOfPkgInfo :: PkgInfo -> (String,String)-pairNameOfPkgInfo pkgi = (nameOfPkgInfo pkgi, versionOfPkgInfo pkgi)--nameOfPkgInfo :: PkgInfo -> String-nameOfPkgInfo = toString . pkgName . sourcePackageId- where- toString (PackageName x) = x--versionOfPkgInfo :: PkgInfo -> String-versionOfPkgInfo = toDotted . numVersionOfPkgInfo--numVersionOfPkgInfo :: PkgInfo -> [Int]-numVersionOfPkgInfo = versionBranch . pkgVersion . sourcePackageId--------------------------------------------------------------------extraInfo :: Bool -> PkgInfo -> IO ()-extraInfo False _ = return ()-extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ auth ++ "\""- where- lcns = showLicense (license pkgi)- auth = author pkgi--------------------------------------------------------------------printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()-printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi--printDep :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageId -> IO ()-printDep rec info db n pid = case lookupInstalledPackageId db pid of- Nothing -> return ()- Just pkgi -> do- putStr $ prefix ++ fullNameOfPkgInfo pkgi- extraInfo info pkgi- putStrLn ""- when rec $ printDeps rec info db (n+1) pkgi- where- prefix = replicate (n * 4) ' '--showLicense :: License -> String-showLicense (GPL (Just v)) = "GPL" ++ version v-showLicense (GPL Nothing) = "GPL"-showLicense (LGPL (Just v)) = "LGPL" ++ version v-showLicense (LGPL Nothing) = "LGPL"-showLicense (UnknownLicense s) = s-showLicense x = show x--------------------------------------------------------------------printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()-printRevDeps rec info db n pkgi = printRevDeps' rec info db revdb n pkgi- where- revdb = makeRevDepDB db--printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO ()-printRevDeps' rec info db revdb n pkgi = case M.lookup pkgid revdb of- Nothing -> return ()- Just pkgids -> mapM_ (printRevDep' rec info db revdb n) pkgids- where- pkgid = installedPackageId pkgi--printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO ()-printRevDep' rec info db revdb n pid = case lookupInstalledPackageId db pid of- Nothing -> return ()- Just pkgi -> do- putStr $ prefix ++ fullNameOfPkgInfo pkgi- extraInfo info pkgi- putStrLn ""- when rec $ printRevDeps' rec info db revdb (n+1) pkgi- where- prefix = replicate (n * 4) ' '--------------------------------------------------------------------type RevDB = Map InstalledPackageId [InstalledPackageId]--makeRevDepDB :: PkgDB -> RevDB-makeRevDepDB db = M.fromList revdeps- where- pkgs = allPackages db- deps = map idDeps pkgs- idDeps pkg = (installedPackageId pkg, depends pkg)- kvs = sort $ concatMap decomp deps- decomp (k,vs) = map (\v -> (v,k)) vs- kvss = groupBy ((==) `on` fst) kvs- comp xs = (fst (head xs), map snd xs)- revdeps = map comp kvss--------------------------------------------------------------------topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo]-topSortedPkgs pkgi db = topSort $ pkgids [pkgi]- where- pkgids = map installedPackageId- topSort = topologicalOrder . fromList . reverseDependencyClosure db
− Program.hs
@@ -1,13 +0,0 @@-module Program (- version, showVersion- , programName, description- ) where--import Paths_cab-import Data.Version--programName :: String-programName = "cab"--description :: String-description = "A maintenance command of Haskell cabal packages"
− Types.hs
@@ -1,122 +0,0 @@-module Types where--import Data.List-import System.Console.GetOpt--type Arg = String-type UnknownOpt = String-type ParsedArgs = Either [UnknownOpt] ([Arg],[Option])--------------------------------------------------------------------data Switch = SwNoharm- | SwRecursive- | SwAll- | SwInfo- | SwSandbox- | SwFlag- | SwTest- | SwBench- deriving (Eq,Show)--data Option = OptNoharm- | OptRecursive- | OptAll- | OptInfo- | OptSandbox String- | OptFlag String- | OptTest- | OptHelp- | OptBench- deriving (Eq,Show)--toSwitch :: Option -> Switch-toSwitch OptNoharm = SwNoharm-toSwitch OptRecursive = SwRecursive-toSwitch OptAll = SwAll-toSwitch OptInfo = SwInfo-toSwitch (OptSandbox _) = SwSandbox-toSwitch (OptFlag _) = SwFlag-toSwitch OptTest = SwTest-toSwitch OptBench = SwBench-toSwitch _ = error "toSwitch"--getSandbox :: [Option] -> Maybe FilePath-getSandbox = getValue (\x -> toSwitch x == SwSandbox)--getFlag :: [Option] -> Maybe FilePath-getFlag = getValue (\x -> toSwitch x == SwFlag)--getValue :: (Option -> Bool) -> [Option] -> Maybe FilePath-getValue p opts = case find p opts of- Nothing -> Nothing- Just (OptSandbox path) -> Just path- _ -> error "getSandbox"--type SwitchSpec = (Switch, Maybe String)-type SwitchDB = [SwitchSpec]--type GetOptSpec = OptDescr Option-type GetOptDB = [GetOptSpec]--type OptionSpec = (Switch,GetOptSpec)-type OptionDB = [OptionSpec]--------------------------------------------------------------------data Command = Sync- | Install- | Uninstall- | Installed- | Configure- | Build- | Clean- | Outdated- | Sdist- | Upload- | Unpack- | Info- | Deps- | RevDeps- | Check- | GenPaths- | Search- | Env- | Add- | Ghci- | Test- | Bench- | Doc- | Help- deriving (Eq,Show)--data CommandSpec = CommandSpec {- command :: Command- , commandNames :: [String]- , document :: String- , routing :: Route- , switches :: SwitchDB- , manual :: Maybe String- }--type CommandDB = [CommandSpec]--------------------------------------------------------------------type FunctionCommand = CommandSpec -> [String] -> [Option] -> IO ()--data Route = RouteFunc FunctionCommand- | RouteCabal [String]--cabalCommand :: [Option] -> String-cabalCommand opts- | SwSandbox `elem` map toSwitch opts = "cabal-dev"- | otherwise = "cabal"--------------------------------------------------------------------cabEnvVar :: String-cabEnvVar = "CAB_SANDBOX_PATH"--ghcEnvVar :: String-ghcEnvVar = "GHC_PACKAGE_PATH"
− Utils.hs
@@ -1,21 +0,0 @@-module Utils where--import Data.List--fromDotted :: String -> [Int]-fromDotted [] = []-fromDotted xs = case break (=='.') xs of- (x,"") -> [read x :: Int]- (x,_:ys) -> (read x :: Int) : fromDotted ys--toDotted :: [Int] -> String-toDotted = joinBy "." . map show--joinBy :: String -> [String] -> String-joinBy = intercalate--split :: Int -> [a] -> [[a]]-split _ [] = []-split n ss = x : split n rest- where- (x,rest) = splitAt n ss
− VerDB.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module VerDB (- VerDB, getVerDB, lookupLatestVersion, getVerAlist- ) where--import Control.Applicative-import Control.Arrow (second)-import Data.Attoparsec.ByteString.Char8-import Data.Conduit-import Data.Conduit.Attoparsec-import Data.Conduit.Process-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe--------------------------------------------------------------------type VerInfo = (String, Maybe [Int])--data VerDB = VerDB (Map String [Int])--------------------------------------------------------------------getVerDB :: IO VerDB-getVerDB = VerDB . M.fromList <$> getVerAlist True--getVerAlist :: Bool -> IO [(String,[Int])]-getVerAlist installedOnly = justOnly <$> verInfos- where- script = if installedOnly- then "cabal list --installed"- else "cabal list"- verInfos = runResourceT $ sourceCmd script $$ cabalListParser- justOnly = map (second fromJust) . filter (isJust . snd)-- cabalListParser = sinkParser verinfos--------------------------------------------------------------------lookupLatestVersion :: String -> VerDB -> Maybe [Int]-lookupLatestVersion pkgid (VerDB db) = M.lookup pkgid db--------------------------------------------------------------------verinfos :: Parser [VerInfo]-verinfos = many1 verinfo--verinfo :: Parser VerInfo-verinfo = do- name <- string "* " *> nonEols <* endOfLine- synpsis- lat <- latestLabel *> latest <* endOfLine- _ <- many skip- endOfLine- return (name, lat)- where- latestLabel = string " Default available version: " -- cabal 0.10- <|> string " Latest version available: " -- cabal 0.8- skip = many1 nonEols *> endOfLine- synpsis = string " Synopsis:" *> nonEols *> endOfLine *> more- <|> return ()- where- more = () <$ many (string " " *> nonEols *> endOfLine)- latest = Nothing <$ (char '[' *> nonEols)- <|> Just <$> dotted--dotted :: Parser [Int]-dotted = decimal `sepBy` char '.'--nonEols :: Parser String-nonEols = many1 $ satisfy (notInClass "\r\n")
cab.cabal view
@@ -1,5 +1,5 @@ Name: cab-Version: 0.1.15+Version: 0.2.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -14,14 +14,41 @@ this command helps you. Homepage: http://www.mew.org/~kazu/proj/cab/ Category: Distribution-Cabal-Version: >= 1.6+Cabal-Version: >= 1.10 Build-Type: Simple +Library+ Default-Language: Haskell2010+ GHC-Options: -Wall+ Build-Depends: base >= 4.0 && < 5+ , Cabal+ , attoparsec >= 0.10+ , attoparsec-conduit >= 0.3+ , bytestring+ , conduit >= 0.3+ , containers+ , directory+ , filepath+ , process+ , process-conduit >= 0.1+ Exposed-Modules: Distribution.Cab+ Distribution.Cab.PkgDB+ Distribution.Cab.Printer+ Distribution.Cab.Sandbox+ Distribution.Cab.VerDB+ Distribution.Cab.Version+ Other-Modules: Distribution.Cab.Commands+ Distribution.Cab.GenPaths+ Distribution.Cab.Utils+ Executable cab+ Default-Language: Haskell2010 Main-Is: Main.hs GHC-Options: -Wall+ HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5- , Cabal+ , cab+ , Cabal >= 1.18 , attoparsec >= 0.10 , attoparsec-conduit >= 0.3 , bytestring@@ -35,16 +62,22 @@ Build-Depends: else Build-Depends: unix- Other-Modules: CmdDB- Commands- Env- GenPaths- PkgDB+ Other-Modules: Commands+ Help+ Options Program Types- Utils- VerDB Paths_cab++-- Test-Suite doctest+-- Type: exitcode-stdio-1.0+-- Default-Language: Haskell2010+-- HS-Source-Dirs: test+-- Ghc-Options: -threaded -Wall+-- Main-Is: doctests.hs+-- Build-Depends: base+-- , doctest >= 0.9.3+ Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/cab.git
+ src/Commands.hs view
@@ -0,0 +1,235 @@+module Commands (commandDB, commandSpecByName) where++import Distribution.Cab++import {-# SOURCE #-} Help (helpCommandAndExit)+import Types++----------------------------------------------------------------++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, Solo "--dry-run -v")+ ,(SwFlag, WithArg "--flags")+ ,(SwTest, Solo "--enable-tests")+ ,(SwDepsOnly, Solo "--only-dependencies")+ ,(SwLibProfile, Solo "--enable-library-profiling")+ ,(SwExecProfile, Solo "--enable-executable-profiling")+ ,(SwJobs, WithArg "--jobs")+ ]+ , manual = Just "[<package> [<ver>]]"+ }+ , CommandSpec {+ command = Uninstall+ , commandNames = ["uninstall", "delete", "remove", "unregister"]+ , document = "Uninstall packages"+ , routing = RouteFunc uninstall+ , switches = [(SwNoharm, None)+ ,(SwRecursive, None)+ ] -- don't allow SwAll+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = Installed+ , commandNames = ["installed", "list"]+ , document = "List installed packages"+ , routing = RouteFunc installed+ , switches = [(SwAll, None)+ ,(SwRecursive, None)+ ,(SwInfo, None)+ ]+ , manual = Nothing+ }+ , CommandSpec {+ command = Configure+ , commandNames = ["configure", "conf"]+ , document = "Configure a cabal package"+ , routing = RouteCabal ["configure"]+ , switches = [(SwFlag, WithArg "--flags")+ ,(SwTest, Solo "--enable-tests")+ ,(SwBench, Solo "--enable-benchmarks")+ ,(SwLibProfile, Solo "--enable-library-profiling")+ ,(SwExecProfile, Solo "--enable-executable-profiling")+ ]+ , manual = Nothing+ }+ , CommandSpec {+ command = Build+ , commandNames = ["build"]+ , document = "Build a cabal package"+ , routing = RouteCabal ["build"]+ , switches = [(SwJobs, WithArg "--jobs")]+ , 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, None)]+ , manual = Nothing+ }+ , CommandSpec {+ command = Info+ , commandNames = ["info"]+ , document = "Display information of a package"+ , routing = RouteCabal ["info"]+ , switches = []+ , 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, Solo "-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, None)+ ,(SwAll, None)+ ,(SwInfo, None)+ ]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = RevDeps+ , commandNames = ["revdeps", "dependents"]+ , document = "Show reverse dependencies of this package"+ , routing = RouteFunc revdeps+ , switches = [(SwRecursive, None)+ ,(SwAll, None)+ ,(SwInfo, None)+ ]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = Check+ , commandNames = ["check"]+ , document = "Check consistency of packages"+ , routing = RouteFunc check+ , switches = []+ , 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 = Add+ , commandNames = ["add", "add-source"]+ , document = "Add a source directory"+ , routing = RouteFunc add+ , switches = []+ , manual = Just "<source>"+ }+ , CommandSpec {+ command = Test+ , commandNames = ["test"]+ , document = "Run tests"+ , routing = RouteCabal ["test"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Bench+ , commandNames = ["bench"]+ , document = "Run benchmarks"+ , routing = RouteCabal ["bench"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Doc+ , commandNames = ["doc", "haddock", "man"]+ , document = "Generate manuals"+ , routing = RouteCabal ["haddock", "--hyperlink-source"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Ghci+ , commandNames = ["ghci", "repl"]+ , document = "Run GHCi (with a sandbox)"+ , routing = RouteFunc ghci+ , switches = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Init+ , commandNames = ["init"]+ , document = "Initialize a sandbox"+ , routing = RouteFunc initSandbox+ , switches = []+ , manual = Nothing+ }+ , 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
+ src/Help.hs view
@@ -0,0 +1,111 @@+module Help (+ helpAndExit+ , helpCommandAndExit+ , illegalOptionsAndExit+ , illegalCommandAndExit+ ) where++import Control.Monad+import Data.List+import Distribution.Cab+import System.Console.GetOpt+import System.Exit+import System.IO++import Commands+import Options+import Program+import Types++----------------------------------------------------------------++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++----------------------------------------------------------------++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++----------------------------------------------------------------++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
+ src/Help.hs-boot view
@@ -0,0 +1,5 @@+module Help where++import Distribution.Cab++helpCommandAndExit :: FunctionCommand
+ src/Main.hs view
@@ -0,0 +1,104 @@+module Main where++import Control.Exception (Handler(..))+import qualified Control.Exception as E+import Control.Monad+import Data.Maybe+import Data.List (isPrefixOf)+import Distribution.Cab+import System.Cmd+import System.Console.GetOpt+import System.Environment+import System.Exit++import Commands+import Help+import Options+import Types++----------------------------------------------------------------++main :: IO ()+main = flip E.catches handlers $ do+ oargs <- getArgs+ let pargs = parseArgs getOptDB oargs+ checkOptions1 pargs illegalOptionsAndExit+ let Right (args,opts0) = pargs+ when (args == []) helpAndExit+ when (OptHelp `elem` opts0) $ helpCommandAndExit args undefined+ let opts1 = filter (/= OptHelp) opts0+ act:params = args+ mcmdspec = commandSpecByName act commandDB+ when (isNothing mcmdspec) (illegalCommandAndExit act)+ let Just cmdspec = mcmdspec+ checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit+ run cmdspec params opts1+ where+ handlers = [Handler handleExit]+ handleExit :: ExitCode -> IO ()+ handleExit _ = return ()++----------------------------------------------------------------++parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs+parseArgs db args = case getOpt' Permute db args of+ (o,n,[],[]) -> Right (n,o)+ (_,_,unknowns,_) -> Left unknowns++checkOptions1 :: ParsedArgs -> ([UnknownOpt] -> IO ()) -> IO ()+checkOptions1 (Left es) func = func es+checkOptions1 _ _ = return ()++checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> ([UnknownOpt] -> IO ()) -> IO ()+checkOptions2 opts cmdspec oargs func = do+ let unknowns = chk specified supported+ when (unknowns /= []) $ func (concatMap (resolveOptionString oargs) unknowns)+ where+ chk [] _ = []+ chk (x:xs) ys+ | x `elem` ys = chk xs ys+ | otherwise = x : chk xs ys+ specified = map toSwitch opts+ supported = map fst $ switches cmdspec++----------------------------------------------------------------++run :: CommandSpec -> [Arg] -> [Option] -> IO ()+run cmdspec params opts = case routing cmdspec of+ RouteFunc func -> func params opts+ RouteCabal subargs -> callProcess pro subargs params opts sws+ where+ pro = "cabal"+ sws = switches cmdspec++callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO ()+callProcess pro args0 args1 opts sws = void . system $ script+ where+ swchs = optionsToString opts sws+ script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs+ cat [pkg,ver] = [pkg ++ "-" ++ ver]+ cat x = x++----------------------------------------------------------------++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 None -> []+ Just (Solo x) -> [x]+ Just (WithArg x) -> [x ++ "=" ++ optionArg opt]
+ src/Options.hs view
@@ -0,0 +1,51 @@+module Options (optionDB, getOptDB) where++import Distribution.Cab+import System.Console.GetOpt++import Types++----------------------------------------------------------------++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 ['f'] ["flags"]+ (ReqArg OptFlag "<flags>")+ "Specify flags"+ , Option ['t'] ["test"]+ (NoArg OptTest)+ "Enable test"+ , Option ['b'] ["bench"]+ (NoArg OptBench)+ "Enable benchmark"+ , Option ['d'] ["dep-only"]+ (NoArg OptDepsOnly)+ "Target only dependencies"+ , Option ['p'] ["libr-prof"]+ (NoArg OptLibProfile)+ "Enable library profiling"+ , Option ['e'] ["exec-prof"]+ (NoArg OptExecProfile)+ "Enable library profiling"+ , Option ['j'] ["jobs"]+ (ReqArg OptJobs "<jobs>")+ "Run N jobs"+ , Option ['h'] ["help"]+ (NoArg OptHelp)+ "Show help message"+ ]++optionDB :: OptionDB+optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwFlag,SwTest,SwBench,SwDepsOnly,SwLibProfile,SwExecProfile,SwJobs] getOptDB
+ src/Program.hs view
@@ -0,0 +1,13 @@+module Program (+ version, showVersion+ , programName, description+ ) where++import Paths_cab+import Data.Version++programName :: String+programName = "cab"++description :: String+description = "A maintenance command of Haskell cabal packages"
+ src/Types.hs view
@@ -0,0 +1,101 @@+module Types where++import Distribution.Cab+import System.Console.GetOpt++type Arg = String+type UnknownOpt = String+type ParsedArgs = Either [UnknownOpt] ([Arg],[Option])++----------------------------------------------------------------++data Switch = SwNoharm+ | SwRecursive+ | SwAll+ | SwInfo+ | SwFlag+ | SwTest+ | SwBench+ | SwDepsOnly+ | SwLibProfile+ | SwExecProfile+ | SwJobs+ deriving (Eq,Show)++toSwitch :: Option -> Switch+toSwitch OptNoharm = SwNoharm+toSwitch OptRecursive = SwRecursive+toSwitch OptAll = SwAll+toSwitch OptInfo = SwInfo+toSwitch (OptFlag _) = SwFlag+toSwitch OptTest = SwTest+toSwitch OptBench = SwBench+toSwitch OptDepsOnly = SwDepsOnly+toSwitch OptLibProfile = SwLibProfile+toSwitch OptExecProfile = SwExecProfile+toSwitch (OptJobs _) = SwJobs+toSwitch _ = error "toSwitch"++----------------------------------------------------------------++optionArg :: Option -> String+optionArg (OptFlag str) = str+optionArg (OptJobs str) = str+optionArg _ = ""++----------------------------------------------------------------++data SwitchKind = None | Solo String | WithArg String++type SwitchSpec = (Switch, SwitchKind)+type SwitchDB = [SwitchSpec]++type GetOptSpec = OptDescr Option+type GetOptDB = [GetOptSpec]++type OptionSpec = (Switch,GetOptSpec)+type OptionDB = [OptionSpec]++----------------------------------------------------------------++data Command = Sync+ | Install+ | Uninstall+ | Installed+ | Configure+ | Build+ | Clean+ | Outdated+ | Sdist+ | Upload+ | Unpack+ | Info+ | Deps+ | RevDeps+ | Check+ | GenPaths+ | Search+ | Add+ | Ghci+ | Test+ | Bench+ | Doc+ | Init+ | Help+ deriving (Eq,Show)++data CommandSpec = CommandSpec {+ command :: Command+ , commandNames :: [String]+ , document :: String+ , routing :: Route+ , switches :: SwitchDB+ , manual :: Maybe String+ }++type CommandDB = [CommandSpec]++----------------------------------------------------------------++data Route = RouteFunc FunctionCommand+ | RouteCabal [String]