diff --git a/CmdDB.hs b/CmdDB.hs --- a/CmdDB.hs +++ b/CmdDB.hs @@ -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 " []" } , 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 " []" } , 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 " []" } , 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 " []" } , 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 " []" } , 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 " []" } , 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 "" } , 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 "" + } + , CommandSpec { command = Help , commandNames = ["help"] , document = "Display the help message of the command" , routing = RouteFunc helpCommandAndExit - , options = [] + , switches = [] , manual = Just "[]" } ] ---------------------------------------------------------------- -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 "") + "Specify a sandbox directory" + , Option ['f'] ["flags"] + (ReqArg OptFlag "") + "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 ++ " [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 = " ++ x @@ -259,7 +325,7 @@ ---------------------------------------------------------------- -illegalOptionsAndExit :: [String] -> IO () +illegalOptionsAndExit :: [UnknownOpt] -> IO () illegalOptionsAndExit xs = do -- FixME hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs exitFailure diff --git a/Commands.hs b/Commands.hs --- a/Commands.hs +++ b/Commands.hs @@ -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." diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/PkgDB.hs b/PkgDB.hs --- a/PkgDB.hs +++ b/PkgDB.hs @@ -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 diff --git a/Program.hs b/Program.hs --- a/Program.hs +++ b/Program.hs @@ -1,7 +1,7 @@ module Program where version :: String -version = "0.0.1" +version = "0.1.0" programName :: String programName = "cab" diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -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" diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -12,7 +12,7 @@ toDotted = joinBy "." . map show joinBy :: String -> [String] -> String -joinBy sep = concat . intersperse sep +joinBy = intercalate split :: Int -> [a] -> [[a]] split _ [] = [] diff --git a/cab.cabal b/cab.cabal --- a/cab.cabal +++ b/cab.cabal @@ -1,5 +1,5 @@ Name: cab -Version: 0.0.1 +Version: 0.1.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3