cab 0.0.1 → 0.1.0
raw patch · 8 files changed
+366/−209 lines, 8 files
Files
- CmdDB.hs +133/−67
- Commands.hs +89/−35
- Main.hs +53/−41
- PkgDB.hs +22/−6
- Program.hs +1/−1
- Types.hs +66/−57
- Utils.hs +1/−1
- cab.cabal +1/−1
CmdDB.hs view
@@ -4,6 +4,7 @@ import Control.Monad import Data.List import Program+import System.Console.GetOpt import System.Exit import System.IO import Types@@ -17,16 +18,20 @@ command = Sync , commandNames = ["sync", "update"] , document = "Fetch the latest package index"- , routing = RouteProc "cabal" ["update"]- , options = []+ , routing = RouteCabal ["update"]+ , switches = [] , manual = Nothing } , CommandSpec { command = Install , commandNames = ["install"] , document = "Install packages"- , routing = RouteProc "cabal" ["install"]- , options = [(OptNoHarm, Just "--dry-run")]+ , routing = RouteCabal ["install"]+ , switches = [(SwNoharm, Just "--dry-run -v")+ -- FIXME cabal-dev not support --dry-run+ ,(SwSandbox, Just "-s")+ ,(SwFlag, Just "-f")+ ] , manual = Just "<package> [<ver>]" } , CommandSpec {@@ -34,9 +39,10 @@ , commandNames = ["uninstall", "delete", "remove", "unregister"] , document = "Uninstall packages" , routing = RouteFunc uninstall- , options = [(OptNoHarm, Nothing)- ,(OptRecursive, Nothing)- ] -- don't allow OptAll+ , switches = [(SwNoharm, Nothing)+ ,(SwRecursive, Nothing)+ ,(SwSandbox, Just "-s")+ ] -- don't allow SwAll , manual = Just "<package> [<ver>]" } , CommandSpec {@@ -44,31 +50,35 @@ , commandNames = ["installed", "list"] , document = "List installed packages" , routing = RouteFunc installed- , options = [(OptAll, Nothing)]+ , switches = [(SwAll, Nothing)+ ,(SwRecursive, Nothing)+ ,(SwSandbox, Just "-s")+ ] , manual = Nothing } , CommandSpec { command = Configure , commandNames = ["configure", "conf"] , document = "Configure a cabal package"- , routing = RouteProc "cabal" ["configure"]- , options = []+ , routing = RouteCabal ["configure"]+ , switches = [(SwSandbox, Just "-s")+ ,(SwFlag, Just "-f")] , manual = Nothing } , CommandSpec { command = Build , commandNames = ["build"] , document = "Build a cabal package"- , routing = RouteProc "cabal" ["build"]- , options = []+ , routing = RouteCabal ["build"]+ , switches = [] , manual = Nothing } , CommandSpec { command = Clean , commandNames = ["clean"] , document = "Clean up a build directory"- , routing = RouteProc "cabal" ["clean"]- , options = []+ , routing = RouteCabal ["clean"]+ , switches = [] , manual = Nothing } , CommandSpec {@@ -76,31 +86,32 @@ , commandNames = ["outdated"] , document = "Display outdated packages" , routing = RouteFunc outdated- , options = [(OptAll, Nothing)]+ , switches = [(SwAll, Nothing)+ ,(SwSandbox, Just "-s")] , manual = Nothing } , CommandSpec { command = Info , commandNames = ["info"] , document = "Display information of a package"- , routing = RouteProc "cabal" ["info"]- , options = []+ , routing = RouteCabal ["info"]+ , switches = [(SwSandbox, Just "-s")] , manual = Just "<package> [<ver>]" } , CommandSpec { command = Sdist , commandNames = ["sdist", "pack"] , document = "Make tar.gz for source distribution"- , routing = RouteProc "cabal" ["sdist"]- , options = []+ , routing = RouteCabal ["sdist"]+ , switches = [] , manual = Nothing } , CommandSpec { command = Unpack , commandNames = ["unpack"] , document = "Untar a package in the current directory"- , routing = RouteProc "cabal" ["unpack"]- , options = []+ , routing = RouteCabal ["unpack"]+ , switches = [] , manual = Just "<package> [<ver>]" } , CommandSpec {@@ -108,9 +119,10 @@ , commandNames = ["deps"] , document = "Show dependencies of this package" , routing = RouteFunc deps- , options = [(OptRecursive, Nothing)- ,(OptAll, Nothing)- ]+ , switches = [(SwRecursive, Nothing)+ ,(SwAll, Nothing)+ ,(SwSandbox, Just "-s")+ ] , manual = Just "<package> [<ver>]" } , CommandSpec {@@ -118,17 +130,18 @@ , commandNames = ["revdeps", "dependents"] , document = "Show reverse dependencies of this package" , routing = RouteFunc revdeps- , options = [(OptRecursive, Nothing)- ,(OptAll, Nothing)- ]+ , switches = [(SwRecursive, Nothing)+ ,(SwAll, Nothing)+ ,(SwSandbox, Just "-s")+ ] , manual = Just "<package> [<ver>]" } , CommandSpec { command = Check , commandNames = ["check"] , document = "Check consistency of packages"- , routing = RouteProc "ghc-pkg" ["check"]- , options = []+ , routing = RouteFunc check+ , switches = [(SwSandbox, Just "-s")] , manual = Nothing } , CommandSpec {@@ -136,56 +149,110 @@ , commandNames = ["search"] , document = "Search available packages by package name" , routing = RouteFunc search- , options = []+ , switches = [] , manual = Just "<key>" } , CommandSpec {+ command = Env+ , commandNames = ["env"]+ , document = "Show environment variables"+ , routing = RouteFunc env+ , switches = [(SwSandbox, Just "-s")]+ , manual = Nothing+ }+ , CommandSpec {+ command = Add+ , commandNames = ["add", "add-source"]+ , document = "Add a source directory"+ , routing = RouteFunc add+ , switches = [(SwSandbox, Just "-s")]+ , manual = Just "<source>"+ }+ , CommandSpec { command = Help , commandNames = ["help"] , document = "Display the help message of the command" , routing = RouteFunc helpCommandAndExit- , options = []+ , switches = [] , manual = Just "[<command>]" } ] ---------------------------------------------------------------- -optionDB :: OptionDB-optionDB = [- OptionSpec {- option = OptNoHarm- , optionNames = ["--dry-run", "-n"]- , optionDesc = "Run without destructive operations"- }- , OptionSpec {- option = OptRecursive- , optionNames = ["--recursive", "-r"]- , optionDesc = "Follow dependencies recursively"- }- , OptionSpec {- option = OptAll- , optionNames = ["--all", "-a"]- , optionDesc = "Show global packages in addition to user packages"- }- ]------------------------------------------------------------------- commandSpecByName :: String -> CommandDB -> Maybe CommandSpec commandSpecByName _ [] = Nothing commandSpecByName x (ent:ents) | x `elem` commandNames ent = Just ent | otherwise = commandSpecByName x ents -optionSpecByName :: String -> OptionDB -> Maybe OptionSpec-optionSpecByName _ [] = Nothing-optionSpecByName x (ent:ents)- | x `elem` optionNames ent = Just ent- | otherwise = optionSpecByName 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 ['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,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@@ -202,23 +269,23 @@ exitSuccess where mcmdspec = commandSpecByName cmd commandDB- showOptions cmdspec = joinBy " " $ concatMap (masterOption optionDB) (opts cmdspec)+ showOptions cmdspec = "[" ++ joinBy "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]" showArgs cmdspec = maybe "" (" " ++) $ manual cmdspec- opts = map fst . options+ opts = map fst . switches masterOption [] _ = [] masterOption (spec:specs) o- | option spec == o = (head . optionNames $ spec) : masterOption specs o- | otherwise = masterOption 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 $ options cmdspec+ opts = map fst $ switches cmdspec printOption [] _ = return () printOption (spec:specs) o- | option spec == o =+ | fst spec == o = putStrLn $ (joinBy ", " . reverse . optionNames $ spec) ++ "\t" ++ optionDesc spec | otherwise = printOption specs o@@ -233,15 +300,14 @@ putStrLn "Usage:" putStrLn $ "\t" ++ programName putStrLn $ "\t" ++ programName ++ " <command> [args...]"- putStrLn $ "\t where"+ putStrLn "\t where" printCommands (getCommands commandDB) exitSuccess where getCommands = map concat . split helpCommandNumber . intersperse ", "- . map head- . map commandNames+ . map (head . commandNames) printCommands [] = return () printCommands (x:xs) = do putStrLn $ "\t <command> = " ++ x@@ -259,7 +325,7 @@ ---------------------------------------------------------------- -illegalOptionsAndExit :: [String] -> IO ()+illegalOptionsAndExit :: [UnknownOpt] -> IO () illegalOptionsAndExit xs = do -- FixME hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs exitFailure
Commands.hs view
@@ -1,5 +1,5 @@ module Commands (- deps, revdeps, installed, outdated, uninstall, search+ deps, revdeps, installed, outdated, uninstall, search, env, check, add ) where import Control.Applicative hiding (many)@@ -10,7 +10,7 @@ import Types import Utils import VerDB-import System.Process+import System.Process hiding (env) import Data.List import Data.Char @@ -22,10 +22,10 @@ forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ toDotted v where key = map toLower x- check (n,_) = key `isPrefixOf` map toLower n+ sat (n,_) = key `isPrefixOf` map toLower n lok [] = [] lok (e:es)- | check e = e : lok es+ | sat e = e : lok es | otherwise = lok es search _ _ _ = do hPutStrLn stderr "One search-key should be specified."@@ -34,68 +34,92 @@ ---------------------------------------------------------------- installed :: FunctionCommand-installed _ _ flags = do- flt <- if allFlag flags then allPkgs else userPkgs- pkgs <- toPkgList flt <$> getPkgDB- mapM_ putStrLn $ map fullNameOfPkgInfo pkgs+installed _ _ opts = do+ let optall = OptAll `elem` opts+ optrec = OptRecursive `elem` opts+ flt <- if optall then allPkgs else userPkgs+ db' <- getPkgDB (getSandbox opts)+ let pkgs = toPkgList flt db'+ db <- if optall+ then return db'+ else toPkgDB . flip toPkgList db' <$> userPkgs+ forM_ pkgs $ \pkg -> do+ putStrLn . fullNameOfPkgInfo $ pkg+ when optrec $ printDeps True db 1 pkg outdated :: FunctionCommand-outdated _ _ flags = do- flt <- if allFlag flags then allPkgs else userPkgs- pkgs <- toPkgList flt <$> getPkgDB+outdated _ _ opts = do+ flt <- if OptAll `elem` opts then allPkgs else userPkgs+ pkgs <- toPkgList flt <$> getPkgDB (getSandbox opts) verDB <- getVerDB- forM_ pkgs $ \p -> do- case lookupLatestVersion (nameOfPkgInfo p) verDB of- Nothing -> return ()- Just ver -> if numVersionOfPkgInfo p /= ver- then putStrLn $ fullNameOfPkgInfo p ++ " < " ++ toDotted ver- else return ()+ 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 flags = do- db' <- getPkgDB+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."+ 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) (map pairNameOfPkgInfo sortedPkgs)+ mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs where- onlyOne = not $ recursiveFlag flags- doit = not $ noHarmFlag flags+ onlyOne = OptRecursive `notElem` opts+ doit = OptNoharm `notElem` opts -unregister :: Bool -> (String,String) -> IO ()-unregister doit (name,ver) = if doit+unregister :: Bool -> [Option] -> (String,String) -> IO ()+unregister doit opts (name,ver) = if doit then do putStrLn $ "Deleting " ++ name ++ " " ++ ver- when doit $ system script >> return ()+ pkgconf <- pkgConfOpt opts+ when doit $ system (script pkgconf) >> return () else putStrLn $ name ++ " " ++ ver where- script = "ghc-pkg unregister " ++ name ++ "-" ++ ver+ 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 ++ " "+ ---------------------------------------------------------------- +check :: FunctionCommand+check _ _ opts = do+ pkgconf <- pkgConfOpt opts+ system (script pkgconf)+ return ()+ where+ script pkgconf = "ghc-pkg check " ++ pkgconf++----------------------------------------------------------------+ deps :: FunctionCommand-deps _ nmver flags = printDepends nmver flags printDeps+deps _ nmver opts = printDepends nmver opts printDeps revdeps :: FunctionCommand-revdeps _ nmver flags = printDepends nmver flags printRevDeps+revdeps _ nmver opts = printDepends nmver opts printRevDeps -printDepends :: [String] -> Flags+printDepends :: [String] -> [Option] -> (Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()-printDepends nmver flags func = do- db' <- getPkgDB+printDepends nmver opts func = do+ db' <- getPkgDB (getSandbox opts) pkg <- lookupPkg nmver db'- db <- if allFlag flags+ db <- if OptAll `elem` opts then return db' else toPkgDB . flip toPkgList db' <$> userPkgs- func (recursiveFlag flags) db 0 pkg+ func (OptRecursive `elem` opts) db 0 pkg ---------------------------------------------------------------- @@ -116,5 +140,35 @@ checkOne [pkg] = return pkg checkOne pkgs = do hPutStrLn stderr "Package version must be specified."- mapM_ (hPutStrLn stderr) $ map fullNameOfPkgInfo pkgs+ 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+ putStrLn $ "export CAB_SANDBOX_PATH=" ++ path+ putStrLn $ "setenv CAB_SANDBOX_PATH " ++ path+ putStrLn ""+ putStrLn "The following commands are not necessary in normal case."+ putStrLn $ "export GHC_PACKAGE_PATH=" ++ pkgConf+ putStrLn $ "setenv GHC_PACKAGE_PATH " ++ pkgConf++----------------------------------------------------------------++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] -> do+ system $ "cabal-dev add-source " ++ src ++ " -s " ++ sbox+ return ()+ _ -> hPutStrLn stderr "A source path be specified."
Main.hs view
@@ -4,10 +4,11 @@ import Control.Applicative import Control.Exception import Control.Monad-import Data.List import Data.Maybe+import Prelude hiding (catch) import System.Cmd-import System.Environment (getArgs)+import System.Console.GetOpt+import System.Environment import System.Exit import Types import Utils@@ -16,18 +17,20 @@ main :: IO () main = flip catches handlers $ do- (args,opts) <- argsOpts <$> getArgs+ oargs <- getArgs+ let pargs = parseArgs getOptDB oargs+ checkOptions1 pargs illegalOptionsAndExit+ let Right (args,opts0) = pargs when (args == []) helpAndExit- checkHelp args opts helpCommandAndExit- let act = head args+ 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- params = tail args- eoptspecs = parseOptions cmdspec opts- checkOptions eoptspecs illegalOptionsAndExit- let Right flags = eoptspecs- run cmdspec params flags+ checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit+ opts <- sandboxEnv cmdspec opts1+ run cmdspec params opts where handlers = [Handler handleExit] handleExit :: ExitCode -> IO ()@@ -35,45 +38,54 @@ ---------------------------------------------------------------- -argsOpts :: [String] -> ([String],[String])-argsOpts args = (args', opts)- where- args' = filter (not . isPrefixOf "-") args- opts = filter (isPrefixOf "-") args+parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs+parseArgs db args = case getOpt' Permute db args of+ (o,n,[],[]) -> Right (n,o)+ (_,_,unknowns,_) -> Left unknowns -parseOptions :: CommandSpec -> [String] -> Either [String] Flags-parseOptions cmdspc opts = check opts [] defaultFlags+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- optMvals = options cmdspc- check [] [] fg = Right fg- check [] es _ = Left es- check (o:os) es fg = case optionSpecByName o optionDB of- Nothing -> check os (o:es) fg- Just x -> case lookup (option x) optMvals of- Nothing -> check os (o:es) fg- Just mval -> check os es (updateFlags (option x) mval fg)+ 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 -checkHelp :: [String] -> [String] -> FunctionCommand -> IO ()-checkHelp args opts func- | "-h" `elem` opts- || "--help" `elem` opts = func undefined args undefined- | otherwise = return ()+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 -checkOptions :: Either [String] Flags -> ([String] -> IO ()) -> IO ()-checkOptions (Left xs) func = func xs-checkOptions _ _ = return ()+hasSandboxOption :: CommandSpec -> Bool+hasSandboxOption cmdspec = isJust $ lookup SwSandbox (switches cmdspec) ---------------------------------------------------------------- -run :: CommandSpec -> [String] -> Flags -> IO ()-run cmdspec params flags = case routing cmdspec of- RouteFunc func -> func cmdspec params flags- RouteProc subcmd subargs -> callProcess subcmd subargs params flags+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] -> [String] -> Flags -> IO ()-callProcess pro args0 args1 flags = system script >> return ()+callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO ()+callProcess pro args0 args1 opts sws = system script >> return () where- opts = flagsToOptions flags- script = joinBy " " $ pro : opts ++ args0 ++ cat args1+ swchs = optionsToString opts sws+ script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs cat [pkg,ver] = [pkg ++ "-" ++ ver] cat x = x
PkgDB.hs view
@@ -5,6 +5,8 @@ import Data.List import Data.Map (Map) import qualified Data.Map as M+import Distribution.Compiler+ (CompilerId(..)) import Distribution.Version (Version(..)) import Distribution.InstalledPackageInfo@@ -12,7 +14,7 @@ import Distribution.Package (PackageName(..), PackageIdentifier(..), InstalledPackageId) import Distribution.Simple.Compiler- (PackageDB(..))+ (PackageDB(..),Compiler(..)) import Distribution.Simple.GHC (configure, getInstalledPackages) import Distribution.Simple.PackageIndex@@ -32,11 +34,25 @@ ---------------------------------------------------------------- -getPkgDB :: IO PkgDB-getPkgDB = do- (_,pro) <- configure normal Nothing Nothing defaultProgramDb- getInstalledPackages normal [GlobalPackageDB,UserPackageDB] pro+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 +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 ++ ".conf"+ where+ CompilerId _ ver = compilerId com+ version = toDotted . versionBranch $ ver+ toPkgDB :: [PkgInfo] -> PkgDB toPkgDB = fromList @@ -115,7 +131,7 @@ printRevDeps' :: Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO () printRevDeps' rec db revdb n pkgi = case M.lookup pkgid revdb of Nothing -> return ()- Just pkgids -> mapM_ (printRevDep' rec db revdb n) $ pkgids+ Just pkgids -> mapM_ (printRevDep' rec db revdb n) pkgids where pkgid = installedPackageId pkgi
Program.hs view
@@ -1,7 +1,7 @@ module Program where version :: String-version = "0.0.1"+version = "0.1.0" programName :: String programName = "cab"
Types.hs view
@@ -1,9 +1,60 @@ module Types where -import Data.Maybe+import Data.List+import System.Console.GetOpt +type Arg = String+type UnknownOpt = String+type ParsedArgs = Either [UnknownOpt] ([Arg],[Option])+ ---------------------------------------------------------------- +data Switch = SwNoharm+ | SwRecursive+ | SwAll+ | SwSandbox+ | SwFlag+ deriving (Eq,Show)++data Option = OptNoharm+ | OptRecursive+ | OptAll+ | OptSandbox String+ | OptFlag String+ | OptHelp+ deriving (Eq,Show)++toSwitch :: Option -> Switch+toSwitch OptNoharm = SwNoharm+toSwitch OptRecursive = SwRecursive+toSwitch OptAll = SwAll+toSwitch (OptSandbox _) = SwSandbox+toSwitch (OptFlag _) = SwFlag+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@@ -19,6 +70,8 @@ | RevDeps | Check | Search+ | Env+ | Add | Help deriving (Eq,Show) @@ -27,7 +80,7 @@ , commandNames :: [String] , document :: String , routing :: Route- , options :: [(Option, Maybe String)]+ , switches :: SwitchDB , manual :: Maybe String } @@ -35,64 +88,20 @@ ---------------------------------------------------------------- -data Option = OptNoHarm- | OptRecursive- | OptAll- deriving (Eq,Show)--data OptionSpec = OptionSpec {- option :: Option- , optionNames :: [String]- , optionDesc :: String- }--type OptionDB = [OptionSpec]--data Flags = Flags {- noHarmFlag :: Bool- , noHarmOption :: Maybe String- , recursiveFlag :: Bool- , recursiveOption :: Maybe String- , allFlag :: Bool- , allOption :: Maybe String- }--defaultFlags :: Flags-defaultFlags = Flags {- noHarmFlag = False- , noHarmOption = Nothing- , recursiveFlag = False- , recursiveOption = Nothing- , allFlag = False- , allOption = Nothing- }+type FunctionCommand = CommandSpec -> [String] -> [Option] -> IO () -updateFlags :: Option -> Maybe String -> Flags -> Flags-updateFlags OptNoHarm val flg = flg {- noHarmFlag = True- , noHarmOption = val- }-updateFlags OptRecursive val flg = flg {- recursiveFlag = True- , recursiveOption = val- }-updateFlags OptAll val flg = flg {- allFlag = True- , allOption = val- }+data Route = RouteFunc FunctionCommand+ | RouteCabal [String] -flagsToOptions :: Flags -> [String]-flagsToOptions flags = catMaybes [- noHarmOption flags- , recursiveOption flags- , allOption flags- ]+cabalCommand :: [Option] -> String+cabalCommand opts+ | SwSandbox `elem` map toSwitch opts = "cabal-dev"+ | otherwise = "cabal" ---------------------------------------------------------------- -type FunctionCommand = CommandSpec -> [String] -> Flags -> IO ()--data Route = RouteFunc FunctionCommand- | RouteProc String [String]+cabEnvVar :: String+cabEnvVar = "CAB_SANDBOX_PATH" -----------------------------------------------------------------+ghcEnvVar :: String+ghcEnvVar = "GHC_PACKAGE_PATH"
Utils.hs view
@@ -12,7 +12,7 @@ toDotted = joinBy "." . map show joinBy :: String -> [String] -> String-joinBy sep = concat . intersperse sep+joinBy = intercalate split :: Int -> [a] -> [[a]] split _ [] = []
cab.cabal view
@@ -1,5 +1,5 @@ Name: cab-Version: 0.0.1+Version: 0.1.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3