cab 0.2.1 → 0.2.2
raw patch · 8 files changed
+181/−154 lines, 8 files
Files
- cab.cabal +3/−1
- src/Commands.hs +4/−13
- src/Doc.hs +54/−0
- src/Help.hs +9/−64
- src/Help.hs-boot +0/−5
- src/Main.hs +48/−46
- src/Run.hs +61/−0
- src/Types.hs +2/−25
cab.cabal view
@@ -1,5 +1,5 @@ Name: cab-Version: 0.2.1+Version: 0.2.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -63,9 +63,11 @@ else Build-Depends: unix Other-Modules: Commands+ Doc Help Options Program+ Run Types Paths_cab
src/Commands.hs view
@@ -1,14 +1,13 @@-module Commands (commandDB, commandSpecByName) where+module Commands where import Distribution.Cab -import {-# SOURCE #-} Help (helpCommandAndExit) import Types ---------------------------------------------------------------- -commandDB :: CommandDB-commandDB = [+commandDB :: FunctionCommand -> [CommandSpec]+commandDB help = [ CommandSpec { command = Sync , commandNames = ["sync", "update"]@@ -220,16 +219,8 @@ command = Help , commandNames = ["help"] , document = "Display the help message of the command"- , routing = RouteFunc helpCommandAndExit+ , routing = RouteFunc help , 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/Doc.hs view
@@ -0,0 +1,54 @@+module Doc where++import Data.List (intercalate)+import System.Console.GetOpt (OptDescr(..), ArgDescr(..))++import Options+import Types++commandSpecByName :: String -> CommandDB -> Maybe CommandSpec+commandSpecByName _ [] = Nothing+commandSpecByName x (ent:ents)+ | x `elem` commandNames ent = Just ent+ | otherwise = commandSpecByName x ents++----------------------------------------------------------------++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 = intercalate ", " . tail . commandNames++----------------------------------------------------------------++optionDoc :: OptionSpec -> (String, String)+optionDoc spec = (key,doc)+ where+ key = intercalate ", " . reverse . optionNames $ spec+ doc = optionDesc spec++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
src/Help.hs view
@@ -1,20 +1,18 @@+-- Only Main.hs depends on Help.hs+-- Only Help.hs depends on Path_cab.hs+ module Help ( helpAndExit , helpCommandAndExit- , illegalOptionsAndExit- , illegalCommandAndExit- , usageDocAlias- , optionDoc ) where -import Control.Monad-import Data.List+import Control.Monad (forM_)+import Data.List (intersperse) import Distribution.Cab-import System.Console.GetOpt-import System.Exit-import System.IO+import System.Exit (exitSuccess) import Commands+import Doc import Options import Program import Types@@ -37,26 +35,7 @@ printOptions cmdspec exitSuccess where- mcmdspec = commandSpecByName cmd commandDB--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 = intercalate ", " . tail . commandNames+ mcmdspec = commandSpecByName cmd (commandDB helpCommandAndExit) printOptions :: CommandSpec -> IO () printOptions cmdspec =@@ -70,28 +49,8 @@ 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-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@@ -101,7 +60,7 @@ putStrLn $ "\t" ++ programName putStrLn $ "\t" ++ programName ++ " <command> [args...]" putStrLn "\t where"- printCommands (getCommands commandDB)+ printCommands . getCommands . commandDB $ helpCommandAndExit exitSuccess where getCommands = map concat@@ -115,20 +74,6 @@ 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: " ++ intercalate " " xs- exitFailure ----------------------------------------------------------------
− src/Help.hs-boot
@@ -1,5 +0,0 @@-module Help where--import Distribution.Cab--helpCommandAndExit :: FunctionCommand
src/Main.hs view
@@ -1,19 +1,21 @@ module Main where import Control.Exception (Handler(..))-import qualified Control.Exception as E-import Control.Monad-import Data.Maybe+import qualified Control.Exception as E (catches)+import Control.Monad (when) import Data.List (isPrefixOf, intercalate)+import Data.Maybe (isNothing) import Distribution.Cab-import System.Cmd-import System.Console.GetOpt-import System.Environment-import System.Exit+import System.Console.GetOpt (ArgOrder(..), OptDescr(..), getOpt')+import System.Environment (getArgs)+import System.Exit (ExitCode, exitFailure)+import System.IO import Commands+import Doc import Help import Options+import Run import Types ----------------------------------------------------------------@@ -28,7 +30,7 @@ when (OptHelp `elem` opts0) $ helpCommandAndExit args [] [] let opts1 = filter (/= OptHelp) opts0 act:params = args- mcmdspec = commandSpecByName act commandDB+ mcmdspec = commandSpecByName act (commandDB helpCommandAndExit) when (isNothing mcmdspec) (illegalCommandAndExit act) let Just cmdspec = mcmdspec checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit@@ -40,20 +42,50 @@ ---------------------------------------------------------------- +illegalCommandAndExit :: String -> IO ()+illegalCommandAndExit x = do+ hPutStrLn stderr $ "Illegal command: " ++ x+ exitFailure++----------------------------------------------------------------++illegalOptionsAndExit :: UnknownOptPrinter+illegalOptionsAndExit xs = do -- FixME+ hPutStrLn stderr $ "Illegal options: " ++ intercalate " " xs+ exitFailure++----------------------------------------------------------------++type ParsedArgs = Either [UnknownOpt] ([Arg],[Option])+ 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 ()+----------------------------------------------------------------++type UnknownOpt = String+type UnknownOptPrinter = [UnknownOpt] -> IO ()++----------------------------------------------------------------++checkOptions1 :: ParsedArgs -> UnknownOptPrinter -> 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)+----------------------------------------------------------------++checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> UnknownOptPrinter -> IO ()+checkOptions2 opts cmdspec oargs func =+ when (unknowns /= []) $+ func (concatMap (resolveOptionString oargs) unknowns) where+ unknowns = unknownOptions opts cmdspec++unknownOptions :: [Option] -> CommandSpec -> [Switch]+unknownOptions opts cmdspec = chk specified supported+ where chk [] _ = [] chk (x:xs) ys | x `elem` ys = chk xs ys@@ -61,30 +93,6 @@ 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 options- RouteCabal subargs -> callProcess pro subargs params options- where- pro = "cabal"- sws = switches cmdspec- options = optionsToString opts sws--callProcess :: String -> [String] -> [Arg] -> [String] -> IO ()-callProcess pro args0 args1 options = void . system $ script- where- script = intercalate " " $ pro : args0 ++ cat args1 ++ options- 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"@@ -94,12 +102,6 @@ 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 (WithEqArg x) -> [x ++ "=" ++ optionArg opt]- Just (FollowArg x) -> [x ++ optionArg opt]+getOptNames :: GetOptSpec -> (String,String)+getOptNames (Option (c:_) (s:_) _ _) = ('-':[c],'-':'-':s)+getOptNames _ = error "getOptNames"
+ src/Run.hs view
@@ -0,0 +1,61 @@+module Run (run, toSwitch) where++import Control.Monad (void)+import Data.List (intercalate)+import Distribution.Cab+import System.Cmd (system)++import Types++----------------------------------------------------------------++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 (OptImport _) = SwImport+toSwitch _ = error "toSwitch"++----------------------------------------------------------------++optionArg :: Option -> String+optionArg (OptFlag str) = str+optionArg (OptJobs str) = str+optionArg (OptImport str) = str+optionArg _ = ""++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 (WithEqArg x) -> [x ++ "=" ++ optionArg opt]+ Just (FollowArg x) -> [x ++ optionArg opt]++----------------------------------------------------------------++run :: CommandSpec -> [Arg] -> [Option] -> IO ()+run cmdspec params opts = case routing cmdspec of+ 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] -> [String] -> IO ()+callProcess pro args0 args1 options = void . system $ script+ where+ script = intercalate " " $ pro : args0 ++ cat args1 ++ options+ cat [pkg,ver] = [pkg ++ "-" ++ ver]+ cat x = x
src/Types.hs view
@@ -3,9 +3,9 @@ import Distribution.Cab import System.Console.GetOpt +----------------------------------------------------------------+ type Arg = String-type UnknownOpt = String-type ParsedArgs = Either [UnknownOpt] ([Arg],[Option]) ---------------------------------------------------------------- @@ -22,29 +22,6 @@ | SwJobs | SwImport 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 (OptImport _) = SwImport-toSwitch _ = error "toSwitch"--------------------------------------------------------------------optionArg :: Option -> String-optionArg (OptFlag str) = str-optionArg (OptJobs str) = str-optionArg (OptImport str) = str-optionArg _ = "" ----------------------------------------------------------------