diff --git a/Distribution/Cab.hs b/Distribution/Cab.hs --- a/Distribution/Cab.hs +++ b/Distribution/Cab.hs @@ -14,10 +14,6 @@ , add , initSandbox , ghci - -- * Utilities - , joinBy - , split ) where import Distribution.Cab.Commands -import Distribution.Cab.Utils diff --git a/Distribution/Cab/Commands.hs b/Distribution/Cab/Commands.hs --- a/Distribution/Cab/Commands.hs +++ b/Distribution/Cab/Commands.hs @@ -8,7 +8,7 @@ import Control.Applicative hiding (many) import Control.Monad import Data.Char -import Data.List +import Data.List (isPrefixOf, intercalate) import qualified Data.Map as M import Distribution.Cab.GenPaths import Distribution.Cab.PkgDB @@ -16,14 +16,13 @@ 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 () +type FunctionCommand = [String] -> [Option] -> [String] -> IO () data Option = OptNoharm | OptRecursive @@ -37,26 +36,27 @@ | OptLibProfile | OptExecProfile | OptJobs String + | OptImport String deriving (Eq,Show) ---------------------------------------------------------------- search :: FunctionCommand -search [x] _ = do +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 +search _ _ _ = do hPutStrLn stderr "One search-key should be specified." exitFailure ---------------------------------------------------------------- installed :: FunctionCommand -installed _ opts = do +installed _ opts _ = do db <- getDB opts let pkgs = toPkgInfos db forM_ pkgs $ \pkgi -> do @@ -69,7 +69,7 @@ optrec = OptRecursive `elem` opts outdated :: FunctionCommand -outdated _ opts = do +outdated _ opts _ = do pkgs <- toPkgInfos <$> getDB opts verDB <- toMap <$> getVerDB InstalledOnly forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of @@ -87,7 +87,7 @@ ---------------------------------------------------------------- uninstall :: FunctionCommand -uninstall nmver opts = do +uninstall nmver opts _ = do userDB <- getSandbox >>= getUserPkgDB pkg <- lookupPkg nmver userDB let sortedPkgs = topSortedPkgs pkg userDB @@ -105,7 +105,7 @@ unregister doit _ (name,ver) = if doit then do putStrLn $ "Deleting " ++ name ++ " " ++ ver - sandboxOpts <- getSandboxOpts <$> getSandbox + sandboxOpts <- getSandboxOpts2 <$> getSandbox when doit $ void . system $ script sandboxOpts else putStrLn $ name ++ " " ++ ver @@ -115,12 +115,12 @@ ---------------------------------------------------------------- genpaths :: FunctionCommand -genpaths _ _ = genPaths +genpaths _ _ _ = genPaths ---------------------------------------------------------------- check :: FunctionCommand -check _ _ = do +check _ _ _ = do sandboxOpts <- getSandboxOpts <$> getSandbox void . system $ script sandboxOpts where @@ -129,10 +129,10 @@ ---------------------------------------------------------------- deps :: FunctionCommand -deps nmver opts = printDepends nmver opts printDeps +deps nmver opts _ = printDepends nmver opts printDeps revdeps :: FunctionCommand -revdeps nmver opts = printDepends nmver opts printRevDeps +revdeps nmver opts _ = printDepends nmver opts printRevDeps printDepends :: [String] -> [Option] -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO () @@ -170,23 +170,23 @@ ---------------------------------------------------------------- initSandbox :: FunctionCommand -initSandbox [] _ = void . system $ "cabal sandbox init" -initSandbox [path] _ = void . system $ "cabal sandbox init --sandbox " ++ path -initSandbox _ _ = do +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 +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 +ghci args _ options = do + sbxOpts <- getSandboxOpts <$> getSandbox + void $ system $ "ghci" ++ " " ++ sbxOpts ++ " " ++ intercalate " " (options ++ args) diff --git a/Distribution/Cab/Sandbox.hs b/Distribution/Cab/Sandbox.hs --- a/Distribution/Cab/Sandbox.hs +++ b/Distribution/Cab/Sandbox.hs @@ -3,6 +3,7 @@ module Distribution.Cab.Sandbox ( getSandbox , getSandboxOpts + , getSandboxOpts2 ) where import Control.Applicative ((<$>)) @@ -75,6 +76,14 @@ ghcver = extractGhcVer path pkgOpt | ghcver >= 706 = "-package-db " | otherwise = "-package-conf " + +getSandboxOpts2 :: Maybe FilePath -> String +getSandboxOpts2 Nothing = "" +getSandboxOpts2 (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. diff --git a/Distribution/Cab/Utils.hs b/Distribution/Cab/Utils.hs --- a/Distribution/Cab/Utils.hs +++ b/Distribution/Cab/Utils.hs @@ -15,19 +15,4 @@ -- >>> 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 +toDotted = intercalate "." . map show diff --git a/cab.cabal b/cab.cabal --- a/cab.cabal +++ b/cab.cabal @@ -1,5 +1,5 @@ Name: cab -Version: 0.2.0 +Version: 0.2.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/src/Commands.hs b/src/Commands.hs --- a/src/Commands.hs +++ b/src/Commands.hs @@ -23,12 +23,12 @@ , document = "Install packages" , routing = RouteCabal ["install"] , switches = [(SwNoharm, Solo "--dry-run -v") - ,(SwFlag, WithArg "--flags") + ,(SwFlag, WithEqArg "--flags") ,(SwTest, Solo "--enable-tests") ,(SwDepsOnly, Solo "--only-dependencies") ,(SwLibProfile, Solo "--enable-library-profiling") ,(SwExecProfile, Solo "--enable-executable-profiling") - ,(SwJobs, WithArg "--jobs") + ,(SwJobs, WithEqArg "--jobs") ] , manual = Just "[ []]" } @@ -58,7 +58,7 @@ , commandNames = ["configure", "conf"] , document = "Configure a cabal package" , routing = RouteCabal ["configure"] - , switches = [(SwFlag, WithArg "--flags") + , switches = [(SwFlag, WithEqArg "--flags") ,(SwTest, Solo "--enable-tests") ,(SwBench, Solo "--enable-benchmarks") ,(SwLibProfile, Solo "--enable-library-profiling") @@ -71,7 +71,7 @@ , commandNames = ["build"] , document = "Build a cabal package" , routing = RouteCabal ["build"] - , switches = [(SwJobs, WithArg "--jobs")] + , switches = [(SwJobs, WithEqArg "--jobs")] , manual = Nothing } , CommandSpec { @@ -182,7 +182,7 @@ , document = "Run tests" , routing = RouteCabal ["test"] , switches = [] - , manual = Nothing + , manual = Just "[testsuite]" } , CommandSpec { command = Bench @@ -205,7 +205,7 @@ , commandNames = ["ghci", "repl"] , document = "Run GHCi (with a sandbox)" , routing = RouteFunc ghci - , switches = [] + , switches = [(SwImport, FollowArg "-i")] , manual = Nothing } , CommandSpec { diff --git a/src/Help.hs b/src/Help.hs --- a/src/Help.hs +++ b/src/Help.hs @@ -3,6 +3,8 @@ , helpCommandAndExit , illegalOptionsAndExit , illegalCommandAndExit + , usageDocAlias + , optionDoc ) where import Control.Monad @@ -20,29 +22,41 @@ ---------------------------------------------------------------- helpCommandAndExit :: FunctionCommand -helpCommandAndExit [] _ = helpAndExit -helpCommandAndExit (cmd:_) _ = do +helpCommandAndExit [] _ _ = helpAndExit +helpCommandAndExit (cmd:_) _ _ = do case mcmdspec of Nothing -> helpAndExit Just cmdspec -> do - putStrLn $ "Usage: " ++ cmd ++ " " ++ showOptions cmdspec ++ showArgs cmdspec + let (usage,doc,alias) = usageDocAlias cmdspec + putStrLn $ "Usage: " ++ usage putStr "\n" - putStrLn $ document cmdspec + putStrLn $ doc putStr "\n" - putStrLn $ "Aliases: " ++ showAliases cmdspec + putStrLn $ "Aliases: " ++ alias putStr "\n" printOptions cmdspec exitSuccess where mcmdspec = commandSpecByName cmd commandDB - showOptions cmdspec = "[" ++ joinBy "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]" - showArgs cmdspec = maybe "" (" " ++) $ manual cmdspec + +usageDocAlias :: CommandSpec -> (String, String, String) +usageDocAlias cmdspec = (usage,doc,alias) + where + usage = cmd ++ " " ++ showOptions ++ showArgs + doc = document cmdspec + alias = showAliases cmdspec + cmd:_ = commandNames cmdspec + options = opts cmdspec + showOptions + | null options = "" + | otherwise = "[" ++ intercalate "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]" + showArgs = 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 + showAliases = intercalate ", " . tail . commandNames printOptions :: CommandSpec -> IO () printOptions cmdspec = @@ -51,11 +65,17 @@ opts = map fst $ switches cmdspec printOption [] _ = return () printOption (spec:specs) o - | fst spec == o = - putStrLn $ (joinBy ", " . reverse . optionNames $ spec) - ++ "\t" ++ optionDesc spec + | fst spec == o = do + let (key,doc) = optionDoc spec + putStrLn $ key ++ "\t" ++ doc | otherwise = printOption specs o +optionDoc :: OptionSpec -> (String, String) +optionDoc spec = (key,doc) + where + key = intercalate ", " . reverse . optionNames $ spec + doc = optionDesc spec + ---------------------------------------------------------------- optionName :: OptionSpec -> String @@ -107,5 +127,16 @@ illegalOptionsAndExit :: [UnknownOpt] -> IO () illegalOptionsAndExit xs = do -- FixME - hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs + hPutStrLn stderr $ "Illegal options: " ++ intercalate " " xs exitFailure + +---------------------------------------------------------------- + +-- | +-- >>> split 4 "0123457689" +-- ["0123","4576","89"] +split :: Int -> [a] -> [[a]] +split _ [] = [] +split n ss = x : split n rest + where + (x,rest) = splitAt n ss diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ import qualified Control.Exception as E import Control.Monad import Data.Maybe -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, intercalate) import Distribution.Cab import System.Cmd import System.Console.GetOpt @@ -25,7 +25,7 @@ checkOptions1 pargs illegalOptionsAndExit let Right (args,opts0) = pargs when (args == []) helpAndExit - when (OptHelp `elem` opts0) $ helpCommandAndExit args undefined + when (OptHelp `elem` opts0) $ helpCommandAndExit args [] [] let opts1 = filter (/= OptHelp) opts0 act:params = args mcmdspec = commandSpecByName act commandDB @@ -65,17 +65,17 @@ 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 + RouteFunc func -> func params opts options + RouteCabal subargs -> callProcess pro subargs params options where pro = "cabal" sws = switches cmdspec + options = optionsToString opts sws -callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO () -callProcess pro args0 args1 opts sws = void . system $ script +callProcess :: String -> [String] -> [Arg] -> [String] -> IO () +callProcess pro args0 args1 options = void . system $ script where - swchs = optionsToString opts sws - script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs + script = intercalate " " $ pro : args0 ++ cat args1 ++ options cat [pkg,ver] = [pkg ++ "-" ++ ver] cat x = x @@ -98,7 +98,8 @@ 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] + Nothing -> [] + Just None -> [] + Just (Solo x) -> [x] + Just (WithEqArg x) -> [x ++ "=" ++ optionArg opt] + Just (FollowArg x) -> [x ++ optionArg opt] diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -18,7 +18,7 @@ , Option ['a'] ["all"] (NoArg OptAll) "Show global packages in addition to user packages" - , Option ['i'] ["info"] + , Option ['m'] ["info"] (NoArg OptInfo) "Show license and author information" , Option ['f'] ["flags"] @@ -33,7 +33,7 @@ , Option ['d'] ["dep-only"] (NoArg OptDepsOnly) "Target only dependencies" - , Option ['p'] ["libr-prof"] + , Option ['p'] ["lib-prof"] (NoArg OptLibProfile) "Enable library profiling" , Option ['e'] ["exec-prof"] @@ -42,10 +42,13 @@ , Option ['j'] ["jobs"] (ReqArg OptJobs "") "Run N jobs" + , Option ['i'] ["import"] + (ReqArg OptImport ":") + "Add module import paths" , Option ['h'] ["help"] (NoArg OptHelp) "Show help message" ] optionDB :: OptionDB -optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwFlag,SwTest,SwBench,SwDepsOnly,SwLibProfile,SwExecProfile,SwJobs] getOptDB +optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwFlag,SwTest,SwBench,SwDepsOnly,SwLibProfile,SwExecProfile,SwJobs,SwImport] getOptDB diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -20,6 +20,7 @@ | SwLibProfile | SwExecProfile | SwJobs + | SwImport deriving (Eq,Show) toSwitch :: Option -> Switch @@ -34,18 +35,20 @@ toSwitch OptLibProfile = SwLibProfile toSwitch OptExecProfile = SwExecProfile toSwitch (OptJobs _) = SwJobs +toSwitch (OptImport _) = SwImport toSwitch _ = error "toSwitch" ---------------------------------------------------------------- optionArg :: Option -> String -optionArg (OptFlag str) = str -optionArg (OptJobs str) = str -optionArg _ = "" +optionArg (OptFlag str) = str +optionArg (OptJobs str) = str +optionArg (OptImport str) = str +optionArg _ = "" ---------------------------------------------------------------- -data SwitchKind = None | Solo String | WithArg String +data SwitchKind = None | Solo String | WithEqArg String | FollowArg String type SwitchSpec = (Switch, SwitchKind) type SwitchDB = [SwitchSpec]