summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Checks.hs3
-rw-r--r--CmdLine.hs84
-rw-r--r--Command.hs21
3 files changed, 50 insertions, 58 deletions
diff --git a/Checks.hs b/Checks.hs
index cd172c609..6a70fc52d 100644
--- a/Checks.hs
+++ b/Checks.hs
@@ -31,9 +31,6 @@ toOpt = CommandCheck 2 $ do
v <- Annex.getState Annex.toremote
unless (v == Nothing) $ error "cannot use --to with this command"
-checkCommand :: Command -> Annex ()
-checkCommand Command { cmdcheck = c } = sequence_ $ map runCheck c
-
dontCheck :: CommandCheck -> Command -> Command
dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
diff --git a/CmdLine.hs b/CmdLine.hs
index 658b38ab1..af53abc62 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -21,45 +21,41 @@ import qualified Git
import Annex.Content
import Command
+type Params = [String]
+type Flags = [Annex ()]
+
{- Runs the passed command line. -}
-dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
+dispatch :: Params -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
dispatch args cmds options header gitrepo = do
setupConsole
state <- Annex.new gitrepo
- ((cmd, actions), state') <- Annex.run state $ parseCmd args header cmds options
+ (actions, state') <- Annex.run state $ do
+ sequence_ flags
+ prepCommand cmd params
tryRun state' cmd $ [startup] ++ actions ++ [shutdown]
+ where
+ (flags, cmd, params) = parseCmd args cmds options header
-{- Parses command line, stores configure flags, and returns a
- - list of actions to be run in the Annex monad and the Command
- - being run. -}
-parseCmd :: [String] -> String -> [Command] -> [Option] -> Annex (Command, [Annex Bool])
-parseCmd argv header cmds options = do
- (flags, params) <- liftIO getopt
- when (null params) $ error $ "missing command" ++ usagemsg
- let (c:rest) = params
- case lookupCmd c of
- [] -> error $ "unknown command " ++ c ++ " " ++ usagemsg
- [cmd] -> do
- _ <- sequence flags
- checkCommand cmd
- as <- prepCommand cmd rest
- return (cmd, as)
- _ -> error $ "internal error: multiple matching commands for " ++ c
+{- Parses command line, and returns actions to run to configure flags,
+ - the Command being run, and the remaining parameters for the command. -}
+parseCmd :: Params -> [Command] -> [Option] -> String -> (Flags, Command, Params)
+parseCmd argv cmds options header = check $ getOpt Permute options argv
where
- getopt = case getOpt Permute options argv of
- (flags, params, []) ->
- return (flags, params)
- (_, _, errs) ->
- ioError (userError (concat errs ++ usagemsg))
- lookupCmd cmd = filter (\c -> cmd == cmdname c) cmds
- usagemsg = "\n\n" ++ usage header cmds options
+ check (_, [], []) = err "missing command"
+ check (flags, name:rest, [])
+ | null matches = err $ "unknown command " ++ name
+ | otherwise = (flags, head matches, rest)
+ where
+ matches = filter (\c -> name == cmdname c) cmds
+ check (_, _, errs) = err $ concat errs
+ err msg = error $ msg ++ "\n\n" ++ usage header cmds options
{- Usage message with lists of commands and options. -}
usage :: String -> [Command] -> [Option] -> String
-usage header cmds options =
- usageInfo (header ++ "\n\nOptions:") options ++
- "\nCommands:\n" ++ cmddescs
+usage header cmds options = usageInfo top options ++ commands
where
+ top = header ++ "\n\nOptions:"
+ commands = "\nCommands:\n" ++ cmddescs
cmddescs = unlines $ map (indent . showcmd) cmds
showcmd c =
cmdname c ++
@@ -73,23 +69,23 @@ usage header cmds options =
{- Runs a list of Annex actions. Catches IO errors and continues
- (but explicitly thrown errors terminate the whole command).
-}
-tryRun :: Annex.AnnexState -> Command -> [Annex Bool] -> IO ()
+tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
tryRun = tryRun' 0
-tryRun' :: Integer -> Annex.AnnexState -> Command -> [Annex Bool] -> IO ()
-tryRun' errnum state cmd (a:as) = do
- result <- try $ Annex.run state $ do
- Annex.Queue.flushWhenFull
- a
- case result of
- Left err -> do
- Annex.eval state $ do
- showErr err
- showEndFail
- tryRun' (errnum + 1) state cmd as
- Right (True,state') -> tryRun' errnum state' cmd as
- Right (False,state') -> tryRun' (errnum + 1) state' cmd as
-tryRun' errnum _ cmd [] = when (errnum > 0) $
- error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
+tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
+tryRun' errnum _ cmd []
+ | errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
+ | otherwise = return ()
+tryRun' errnum state cmd (a:as) = run >>= handle
+ where
+ run = try $ Annex.run state $ do
+ Annex.Queue.flushWhenFull
+ a
+ handle (Left err) = showerr err >> cont False state
+ handle (Right (success, state')) = cont success state'
+ cont success s = tryRun' (if success then errnum else errnum + 1) s cmd as
+ showerr err = Annex.eval state $ do
+ showErr err
+ showEndFail
{- Actions to perform each time ran. -}
startup :: Annex Bool
diff --git a/Command.hs b/Command.hs
index 74b1ff21c..c11b90610 100644
--- a/Command.hs
+++ b/Command.hs
@@ -46,25 +46,24 @@ next a = return $ Just a
stop :: Annex (Maybe a)
stop = return Nothing
-{- Prepares a list of actions to run to perform a command, based on
- - the parameters passed to it. -}
-prepCommand :: Command -> [String] -> Annex [Annex Bool]
-prepCommand cmd ps = return . map doCommand =<< seekCommand cmd ps
-
-{- Runs a command through the seek stage. -}
-seekCommand :: Command -> [String] -> Annex [CommandStart]
-seekCommand Command { cmdseek = seek } ps = concat <$> mapM (\s -> s ps) seek
+{- Prepares to run a command via the check and seek stages, returning a
+ - list of actions to perform to run the command. -}
+prepCommand :: Command -> [String] -> Annex [CommandCleanup]
+prepCommand Command { cmdseek = seek, cmdcheck = c } params = do
+ sequence_ $ map runCheck c
+ map doCommand . concat <$> mapM (\s -> s params) seek
{- Runs a command through the start, perform and cleanup stages -}
doCommand :: CommandStart -> CommandCleanup
doCommand = start
where
- start = stage $ maybe success perform
+ start = stage $ maybe skip perform
perform = stage $ maybe failure cleanup
- cleanup = stage $ \r -> showEndResult r >> return r
+ cleanup = stage $ status
stage = (=<<)
- success = return True
+ skip = return True
failure = showEndFail >> return False
+ status r = showEndResult r >> return r
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file