diff options
| -rw-r--r-- | Annex.hs | 18 | ||||
| -rw-r--r-- | BackendTypes.hs | 7 | ||||
| -rw-r--r-- | Commands.hs | 50 | ||||
| -rw-r--r-- | Core.hs | 5 | ||||
| -rw-r--r-- | TODO | 2 | ||||
| -rw-r--r-- | Types.hs | 3 | ||||
| -rw-r--r-- | git-annex.hs | 4 |
7 files changed, 59 insertions, 30 deletions
@@ -7,6 +7,9 @@ module Annex ( gitRepoChange, backends, backendsChange, + flagIsSet, + flagsChange, + Flag(..) ) where import Control.Monad.State @@ -18,7 +21,11 @@ import qualified BackendTypes as Backend -} new :: Git.Repo -> IO AnnexState new g = do - let s = Backend.AnnexState { Backend.repo = g, Backend.backends = [] } + let s = Backend.AnnexState { + Backend.repo = g, + Backend.backends = [], + Backend.flags = [] + } (_,s') <- Annex.run s (prep g) return s' where @@ -49,3 +56,12 @@ backendsChange b = do state <- get put state { Backend.backends = b } return () +flagIsSet :: Flag -> Annex Bool +flagIsSet flag = do + state <- get + return $ elem flag $ Backend.flags state +flagsChange :: [Flag] -> Annex () +flagsChange b = do + state <- get + put state { Backend.flags = b } + return () diff --git a/BackendTypes.hs b/BackendTypes.hs index 41ff7e506..1b67ef584 100644 --- a/BackendTypes.hs +++ b/BackendTypes.hs @@ -9,11 +9,16 @@ import Control.Monad.State (StateT) import Data.String.Utils import qualified GitRepo as Git +-- command-line flags +data Flag = Force + deriving (Eq, Read, Show) + -- git-annex's runtime state type doesn't really belong here, -- but it uses Backend, so has to be here to avoid a depends loop. data AnnexState = AnnexState { repo :: Git.Repo, - backends :: [Backend] + backends :: [Backend], + flags :: [Flag] } deriving (Show) -- git-annex's monad diff --git a/Commands.hs b/Commands.hs index 7ff33ab02..a16470fe3 100644 --- a/Commands.hs +++ b/Commands.hs @@ -1,6 +1,6 @@ {- git-annex command line -} -module Commands (argvToActions) where +module Commands (parseCmd) where import System.Console.GetOpt import Control.Monad.State (liftIO) @@ -21,30 +21,34 @@ import Types import Core import qualified Remotes -options :: [OptDescr (String -> Annex ())] -options = - [ Option ['a'] ["add"] (NoArg addCmd) "add files to annex" - , Option ['p'] ["push"] (NoArg pushCmd) "push annex to repos" - , Option ['P'] ["pull"] (NoArg pullCmd) "pull annex from repos" - , Option ['w'] ["want"] (NoArg wantCmd) "request file contents" - , Option ['g'] ["get"] (NoArg getCmd) "transfer file contents" - , Option ['d'] ["drop"] (NoArg dropCmd) "indicate file contents not needed" - , Option ['u'] ["unannex"] (NoArg unannexCmd) "undo --add" - ] - {- Parses command line and returns a list of actons to be run in the Annex - monad. -} -argvToActions :: [String] -> IO [Annex ()] -argvToActions argv = do - case getOpt Permute options argv of - ([],files,[]) -> return $ map defaultCmd files - -- one mode is normal case - (m:[],files,[]) -> return $ map m files - -- multiple modes is an error - (ms,files,[]) -> ioError (userError ("only one mode should be specified\n" ++ usageInfo header options)) - -- error case - (_,files,errs) -> ioError (userError (concat errs ++ usageInfo header options)) - where header = "Usage: git-annex [mode] file" +parseCmd :: [String] -> IO ([Flag], [Annex ()]) +parseCmd argv = do + (flags, nonopts) <- getopt + case (length nonopts) of + 0 -> error header + _ -> do + let c = lookupCmd (nonopts !! 0) + if (0 == length c) + then return $ (flags, map defaultCmd nonopts) + else do + return $ (flags, map (snd $ c !! 0) $ drop 1 nonopts) + where + getopt = case getOpt Permute options argv of + (flags, nonopts, []) -> return (flags, nonopts) + (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options)) + lookupCmd cmd = filter (\(c, a) -> c == cmd) cmds + cmds = [ ("add", addCmd) + , ("push", pushCmd) + , ("pull", pullCmd) + , ("want", wantCmd) + , ("drop", dropCmd) + , ("unannex", unannexCmd) + ] + header = "Usage: git-annex [" ++ + (join "|" $ map fst cmds) ++ "] file ..." + options = [ Option ['f'] ["force"] (NoArg Force) "" ] {- Default mode is to annex a file if it is not already, and otherwise - get its content. -} @@ -12,8 +12,9 @@ import qualified GitRepo as Git import qualified Annex {- Sets up a git repo for git-annex. -} -setup :: Annex () -setup = do +startup :: [Flag] -> Annex () +startup flags = do + Annex.flagsChange flags g <- Annex.gitRepo liftIO $ gitAttributes g prepUUID @@ -3,6 +3,8 @@ * --push/--pull/--want +* recurse on directories + * how to handle git mv file? * finish BackendChecksum @@ -6,7 +6,8 @@ module Types ( Backend, Key, backendName, - keyFrag + keyFrag, + Flag(..), ) where import BackendTypes diff --git a/git-annex.hs b/git-annex.hs index e14739195..cd67242af 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -12,10 +12,10 @@ import qualified GitRepo as Git main = do args <- getArgs - actions <- argvToActions args + (flags, actions) <- parseCmd args gitrepo <- Git.repoFromCwd state <- new gitrepo - tryRun state $ [setup] ++ actions ++ [shutdown] + tryRun state $ [startup flags] ++ actions ++ [shutdown] {- Runs a list of Annex actions. Catches exceptions, not stopping - if some error out, and propigates an overall error status at the end. |