diff options
| -rw-r--r-- | Checks.hs | 3 | ||||
| -rw-r--r-- | CmdLine.hs | 84 | ||||
| -rw-r--r-- | Command.hs | 21 |
3 files changed, 50 insertions, 58 deletions
@@ -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 |