diff --git a/cab.cabal b/cab.cabal --- a/cab.cabal +++ b/cab.cabal @@ -1,5 +1,5 @@ Name: cab -Version: 0.2.1 +Version: 0.2.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -63,9 +63,11 @@ else Build-Depends: unix Other-Modules: Commands + Doc Help Options Program + Run Types Paths_cab diff --git a/src/Commands.hs b/src/Commands.hs --- a/src/Commands.hs +++ b/src/Commands.hs @@ -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 "[]" } ] - ----------------------------------------------------------------- - -commandSpecByName :: String -> CommandDB -> Maybe CommandSpec -commandSpecByName _ [] = Nothing -commandSpecByName x (ent:ents) - | x `elem` commandNames ent = Just ent - | otherwise = commandSpecByName x ents diff --git a/src/Doc.hs b/src/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Doc.hs @@ -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 diff --git a/src/Help.hs b/src/Help.hs --- a/src/Help.hs +++ b/src/Help.hs @@ -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 ++ " [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 ---------------------------------------------------------------- diff --git a/src/Help.hs-boot b/src/Help.hs-boot deleted file mode 100644 --- a/src/Help.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Help where - -import Distribution.Cab - -helpCommandAndExit :: FunctionCommand diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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" diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 _ = "" ----------------------------------------------------------------