add flags, and change to subcommand style

Annex.hs

@@ -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 ()

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

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 ()]
+parseCmd :: [String] -> IO ([Flag], [Annex ()])
-argvToActions argv = do
+parseCmd argv = do
-	case getOpt Permute options argv of
+	(flags, nonopts) <- getopt
-		([],files,[]) -> return $ map defaultCmd files
+	case (length nonopts) of
-		-- one mode is normal case
+		0 -> error header
-		(m:[],files,[]) -> return $ map m files
+		_ -> do
-		-- multiple modes is an error
+			let c = lookupCmd (nonopts !! 0)
-		(ms,files,[]) -> ioError (userError ("only one mode should be specified\n" ++ usageInfo header options))
+			if (0 == length c)
-		-- error case
+				then return $ (flags, map defaultCmd nonopts)
-		(_,files,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+				else do
-	where header = "Usage: git-annex [mode] file"
+					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. -}

Core.hs

@@ -12,8 +12,9 @@ import qualified GitRepo as Git
 import qualified Annex
 			
 {- Sets up a git repo for git-annex. -}
-setup :: Annex ()
+startup :: [Flag] -> Annex ()
-setup = do
+startup flags = do
+	Annex.flagsChange flags
 	g <- Annex.gitRepo
 	liftIO $ gitAttributes g
 	prepUUID

TODO

@@ -3,6 +3,8 @@
 
 * --push/--pull/--want
 
+* recurse on directories
+
 * how to handle git mv file?
 
 * finish BackendChecksum

Types.hs

@@ -6,7 +6,8 @@ module Types (
 	Backend,
 	Key,
 	backendName,
-	keyFrag
+	keyFrag,
+	Flag(..),
 ) where
 
 import BackendTypes

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.