more reorg, spiffed up state monad

AbstractTypes.hs

@@ -1,47 +0,0 @@
-{- git-annex data types, abstract only -}
-
-module AbstractTypes (
-	Annex,
-	AnnexState,
-	makeAnnexState,
-	runAnnexState,
-	gitAnnex,
-	gitAnnexChange,
-	backendsAnnex,
-	backendsAnnexChange,
-
-	Key,
-	Backend
-) where
-
-import Control.Monad.State
-import qualified GitRepo as Git
-import BackendTypes
-
--- constructor
-makeAnnexState :: Git.Repo -> AnnexState
-makeAnnexState g = AnnexState { repo = g, backends = [] }
-
--- performs an action in the Annex monad
-runAnnexState state action = runStateT (action) state
-
--- Annex monad state accessors
-gitAnnex :: Annex Git.Repo
-gitAnnex = do
-	state <- get
-	return (repo state)
-gitAnnexChange :: Git.Repo -> Annex ()
-gitAnnexChange r = do
-	state <- get
-	put state { repo = r }
-	return ()
-backendsAnnex :: Annex [Backend]
-backendsAnnex = do
-	state <- get
-	return (backends state)
-backendsAnnexChange :: [Backend] -> Annex ()
-backendsAnnexChange b = do
-	state <- get
-	put state { backends = b }
-	return ()
-

Annex.hs

@@ -1,189 +1,42 @@
-{- git-annex toplevel code
- -}
+{- git-annex monad -}
 
 module Annex (
-	start,
-	annexCmd,
-	unannexCmd,
-	getCmd,
-	wantCmd,
-	dropCmd,
-	pushCmd,
-	pullCmd
+	new,
+	run,
+	gitRepo,
+	gitRepoChange,
+	backends,
+	backendsChange,
 ) where
 
-import Control.Monad.State (liftIO)
-import System.Posix.Files
-import System.Directory
-import Data.String.Utils
-import List
+import Control.Monad.State
 import qualified GitRepo as Git
-import Utility
-import Locations
-import qualified Backend
-import BackendList
-import UUID
-import LocationLog
-import AbstractTypes
+import Types
+import qualified BackendTypes as Backend
 
-{- Create and returns an Annex state object. 
- - Examines and prepares the git repo.
- -}
-start :: IO AnnexState
-start = do
-	g <- Git.repoFromCwd
-	let s = makeAnnexState g
-	(_,s') <- runAnnexState s (prep g)
-	return s'
-	where
-		prep g = do
-			-- setup git and read its config; update state
-			g' <- liftIO $ Git.configRead g
-			gitAnnexChange g'
-			liftIO $ gitSetup g'
-			backendsAnnexChange $ parseBackendList $
-				Git.configGet g' "annex.backends" ""
-			prepUUID
+-- constructor
+new :: Git.Repo -> AnnexState
+new g = Backend.AnnexState { Backend.repo = g, Backend.backends = [] }
 
-inBackend file yes no = do
-	r <- liftIO $ Backend.lookupFile file
-	case (r) of
-		Just v -> yes v
-		Nothing -> no
-notinBackend file yes no = inBackend file no yes
+-- performs an action in the Annex monad
+run state action = runStateT (action) state
 
-{- Annexes a file, storing it in a backend, and then moving it into
- - the annex directory and setting up the symlink pointing to its content. -}
-annexCmd :: FilePath -> Annex ()
-annexCmd file = inBackend file err $ do
-	liftIO $ checkLegal file
-	stored <- Backend.storeFile file
-	g <- gitAnnex
-	case (stored) of
-		Nothing -> error $ "no backend could store: " ++ file
-		Just (key, backend) -> do
-			logStatus key ValuePresent
-			liftIO $ setup g key backend
-	where
-		err = error $ "already annexed " ++ file
-		checkLegal file = do
-			s <- getSymbolicLinkStatus file
-			if ((isSymbolicLink s) || (not $ isRegularFile s))
-				then error $ "not a regular file: " ++ file
-				else return ()
-		setup g key backend = do
-			let dest = annexLocation g backend key
-			let reldest = annexLocationRelative g backend key
-			createDirectoryIfMissing True (parentDir dest)
-			renameFile file dest
-			createSymbolicLink ((linkTarget file) ++ reldest) file
-			Git.run g ["add", file]
-			Git.run g ["commit", "-m", 
-				("git-annex annexed " ++ file), file]
-		linkTarget file =
-			-- relies on file being relative to the top of the 
-			-- git repo; just replace each subdirectory with ".."
-			if (subdirs > 0)
-				then (join "/" $ take subdirs $ repeat "..") ++ "/"
-				else ""
-			where
-				subdirs = (length $ split "/" file) - 1
-		
-
-{- Inverse of annexCmd. -}
-unannexCmd :: FilePath -> Annex ()
-unannexCmd file = notinBackend file err $ \(key, backend) -> do
-	Backend.dropFile backend key
-	logStatus key ValueMissing
-	g <- gitAnnex
-	let src = annexLocation g backend key
-	liftIO $ moveout g src
-	where
-		err = error $ "not annexed " ++ file
-		moveout g src = do
-			removeFile file
-			Git.run g ["rm", file]
-			Git.run g ["commit", "-m",
-				("git-annex unannexed " ++ file), file]
-			-- git rm deletes empty directories;
-			-- put them back
-			createDirectoryIfMissing True (parentDir file)
-			renameFile src file
-			return ()
-
-{- Gets an annexed file from one of the backends. -}
-getCmd :: FilePath -> Annex ()
-getCmd file = notinBackend file err $ \(key, backend) -> do
-	inannex <- inAnnex backend key
-	if (inannex)
-		then return ()
-		else do
-			g <- gitAnnex
-			let dest = annexLocation g backend key
-			liftIO $ createDirectoryIfMissing True (parentDir dest)
-			success <- Backend.retrieveFile backend key dest
-			if (success)
-				then do
-					logStatus key ValuePresent
-					return ()
-				else error $ "failed to get " ++ file
-	where
-		err = error $ "not annexed " ++ file
-
-{- Indicates a file is wanted. -}
-wantCmd :: FilePath -> Annex ()
-wantCmd file = do error "not implemented" -- TODO
-
-{- Indicates a file is not wanted. -}
-dropCmd :: FilePath -> Annex ()
-dropCmd file = do error "not implemented" -- TODO
-
-{- Pushes all files to a remote repository. -}
-pushCmd :: String -> Annex ()
-pushCmd reponame = do error "not implemented" -- TODO
-
-{- Pulls all files from a remote repository. -}
-pullCmd :: String -> Annex ()
-pullCmd reponame = do error "not implemented" -- TODO
-
-{- Sets up a git repo for git-annex. May be called repeatedly. -}
-gitSetup :: Git.Repo -> IO ()
-gitSetup repo = do
-	-- configure git to use union merge driver on state files
-	exists <- doesFileExist attributes
-	if (not exists)
-		then do
-			writeFile attributes $ attrLine ++ "\n"
-			commit
-		else do
-			content <- readFile attributes
-			if (all (/= attrLine) (lines content))
-				then do
-					appendFile attributes $ attrLine ++ "\n"
-					commit
-				else return ()
-	where
-		attrLine = stateLoc ++ "/*.log merge=union"
-		attributes = Git.attributes repo
-		commit = do
-			Git.run repo ["add", attributes]
-			Git.run repo ["commit", "-m", "git-annex setup", 
-					attributes]
-
-{- Updates the LocationLog when a key's presence changes. -}
-logStatus :: Key -> LogStatus -> Annex ()
-logStatus key status = do
-	g <- gitAnnex
-	u <- getUUID g
-	f <- liftIO $ logChange g key u status
-	liftIO $ commit g f
-	where
-		commit g f = do
-			Git.run g ["add", f]
-			Git.run g ["commit", "-m", "git-annex log update", f]
-
-{- Checks if a given key is currently present in the annexLocation -}
-inAnnex :: Backend -> Key -> Annex Bool
-inAnnex backend key = do
-	g <- gitAnnex
-	liftIO $ doesFileExist $ annexLocation g backend key
+-- Annex monad state accessors
+gitRepo :: Annex Git.Repo
+gitRepo = do
+	state <- get
+	return (Backend.repo state)
+gitRepoChange :: Git.Repo -> Annex ()
+gitRepoChange r = do
+	state <- get
+	put state { Backend.repo = r }
+	return ()
+backends :: Annex [Backend]
+backends = do
+	state <- get
+	return (Backend.backends state)
+backendsChange :: [Backend] -> Annex ()
+backendsChange b = do
+	state <- get
+	put state { Backend.backends = b }
+	return ()

Backend.hs

@@ -29,16 +29,17 @@ import System.Posix.Files
 import BackendList
 import Locations
 import qualified GitRepo as Git
+import qualified Annex
 import Utility
-import AbstractTypes
+import Types
 import BackendTypes
 
 {- Attempts to store a file in one of the backends. -}
 storeFile :: FilePath -> Annex (Maybe (Key, Backend))
 storeFile file = do
-	g <- gitAnnex
+	g <- Annex.gitRepo
 	let relfile = Git.relative g file
-	b <- backendsAnnex
+	b <- Annex.backends
 	storeFile' b file relfile
 storeFile' [] _ _ = return Nothing
 storeFile' (b:bs) file relfile = do

CmdLine.hs

@@ -11,8 +11,8 @@ module CmdLine (
 ) where
 
 import System.Console.GetOpt
-import AbstractTypes
-import Annex
+import Types
+import Commands
 
 data Mode = Add | Push | Pull | Want | Get | Drop | Unannex
 	deriving Show

Commands.hs

@@ -0,0 +1,189 @@
+{- git-annex subcommands -}
+
+module Commands (
+	start,
+	annexCmd,
+	unannexCmd,
+	getCmd,
+	wantCmd,
+	dropCmd,
+	pushCmd,
+	pullCmd
+) where
+
+import Control.Monad.State (liftIO)
+import System.Posix.Files
+import System.Directory
+import Data.String.Utils
+import List
+import qualified GitRepo as Git
+import qualified Annex
+import Utility
+import Locations
+import qualified Backend
+import BackendList
+import UUID
+import LocationLog
+import Types
+
+{- Create and returns an Annex state object. 
+ - Examines and prepares the git repo.
+ -}
+start :: IO AnnexState
+start = do
+	g <- Git.repoFromCwd
+	let s = Annex.new g
+	(_,s') <- Annex.run s (prep g)
+	return s'
+	where
+		prep g = do
+			-- setup git and read its config; update state
+			g' <- liftIO $ Git.configRead g
+			Annex.gitRepoChange g'
+			liftIO $ gitSetup g'
+			Annex.backendsChange $ parseBackendList $
+				Git.configGet g' "annex.backends" ""
+			prepUUID
+
+inBackend file yes no = do
+	r <- liftIO $ Backend.lookupFile file
+	case (r) of
+		Just v -> yes v
+		Nothing -> no
+notinBackend file yes no = inBackend file no yes
+
+{- Annexes a file, storing it in a backend, and then moving it into
+ - the annex directory and setting up the symlink pointing to its content. -}
+annexCmd :: FilePath -> Annex ()
+annexCmd file = inBackend file err $ do
+	liftIO $ checkLegal file
+	stored <- Backend.storeFile file
+	g <- Annex.gitRepo
+	case (stored) of
+		Nothing -> error $ "no backend could store: " ++ file
+		Just (key, backend) -> do
+			logStatus key ValuePresent
+			liftIO $ setup g key backend
+	where
+		err = error $ "already annexed " ++ file
+		checkLegal file = do
+			s <- getSymbolicLinkStatus file
+			if ((isSymbolicLink s) || (not $ isRegularFile s))
+				then error $ "not a regular file: " ++ file
+				else return ()
+		setup g key backend = do
+			let dest = annexLocation g backend key
+			let reldest = annexLocationRelative g backend key
+			createDirectoryIfMissing True (parentDir dest)
+			renameFile file dest
+			createSymbolicLink ((linkTarget file) ++ reldest) file
+			Git.run g ["add", file]
+			Git.run g ["commit", "-m", 
+				("git-annex annexed " ++ file), file]
+		linkTarget file =
+			-- relies on file being relative to the top of the 
+			-- git repo; just replace each subdirectory with ".."
+			if (subdirs > 0)
+				then (join "/" $ take subdirs $ repeat "..") ++ "/"
+				else ""
+			where
+				subdirs = (length $ split "/" file) - 1
+		
+
+{- Inverse of annexCmd. -}
+unannexCmd :: FilePath -> Annex ()
+unannexCmd file = notinBackend file err $ \(key, backend) -> do
+	Backend.dropFile backend key
+	logStatus key ValueMissing
+	g <- Annex.gitRepo
+	let src = annexLocation g backend key
+	liftIO $ moveout g src
+	where
+		err = error $ "not annexed " ++ file
+		moveout g src = do
+			removeFile file
+			Git.run g ["rm", file]
+			Git.run g ["commit", "-m",
+				("git-annex unannexed " ++ file), file]
+			-- git rm deletes empty directories;
+			-- put them back
+			createDirectoryIfMissing True (parentDir file)
+			renameFile src file
+			return ()
+
+{- Gets an annexed file from one of the backends. -}
+getCmd :: FilePath -> Annex ()
+getCmd file = notinBackend file err $ \(key, backend) -> do
+	inannex <- inAnnex backend key
+	if (inannex)
+		then return ()
+		else do
+			g <- Annex.gitRepo
+			let dest = annexLocation g backend key
+			liftIO $ createDirectoryIfMissing True (parentDir dest)
+			success <- Backend.retrieveFile backend key dest
+			if (success)
+				then do
+					logStatus key ValuePresent
+					return ()
+				else error $ "failed to get " ++ file
+	where
+		err = error $ "not annexed " ++ file
+
+{- Indicates a file is wanted. -}
+wantCmd :: FilePath -> Annex ()
+wantCmd file = do error "not implemented" -- TODO
+
+{- Indicates a file is not wanted. -}
+dropCmd :: FilePath -> Annex ()
+dropCmd file = do error "not implemented" -- TODO
+
+{- Pushes all files to a remote repository. -}
+pushCmd :: String -> Annex ()
+pushCmd reponame = do error "not implemented" -- TODO
+
+{- Pulls all files from a remote repository. -}
+pullCmd :: String -> Annex ()
+pullCmd reponame = do error "not implemented" -- TODO
+
+{- Sets up a git repo for git-annex. May be called repeatedly. -}
+gitSetup :: Git.Repo -> IO ()
+gitSetup repo = do
+	-- configure git to use union merge driver on state files
+	exists <- doesFileExist attributes
+	if (not exists)
+		then do
+			writeFile attributes $ attrLine ++ "\n"
+			commit
+		else do
+			content <- readFile attributes
+			if (all (/= attrLine) (lines content))
+				then do
+					appendFile attributes $ attrLine ++ "\n"
+					commit
+				else return ()
+	where
+		attrLine = stateLoc ++ "/*.log merge=union"
+		attributes = Git.attributes repo
+		commit = do
+			Git.run repo ["add", attributes]
+			Git.run repo ["commit", "-m", "git-annex setup", 
+					attributes]
+
+{- Updates the LocationLog when a key's presence changes. -}
+logStatus :: Key -> LogStatus -> Annex ()
+logStatus key status = do
+	g <- Annex.gitRepo
+	u <- getUUID g
+	f <- liftIO $ logChange g key u status
+	liftIO $ commit g f
+	where
+		commit g f = do
+			Git.run g ["add", f]
+			Git.run g ["commit", "-m", "git-annex log update", f]
+
+{- Checks if a given key is currently present in the annexLocation -}
+inAnnex :: Backend -> Key -> Annex Bool
+inAnnex backend key = do
+	g <- Annex.gitRepo
+	liftIO $ doesFileExist $ annexLocation g backend key

LocationLog.hs

@@ -32,7 +32,7 @@ import Data.Char
 import qualified GitRepo as Git
 import Utility
 import UUID
-import AbstractTypes
+import Types
 import Locations
 
 data LogLine = LogLine {

Locations.hs

@@ -11,7 +11,7 @@ module Locations (
 ) where
 
 import Data.String.Utils
-import AbstractTypes
+import Types
 import qualified BackendTypes as Backend
 import qualified GitRepo as Git
 

Remotes.hs

@@ -9,8 +9,9 @@ module Remotes (
 import Control.Monad.State (liftIO)
 import qualified Data.Map as Map
 import Data.String.Utils
-import AbstractTypes
+import Types
 import qualified GitRepo as Git
+import qualified Annex
 import LocationLog
 import Locations
 import UUID
@@ -23,7 +24,7 @@ list remotes = join " " $ map Git.repoDescribe remotes
 {- Cost ordered list of remotes that the LocationLog indicate may have a key. -}
 withKey :: Key -> Annex [Git.Repo]
 withKey key = do
-	g <- gitAnnex
+	g <- Annex.gitRepo
 	uuids <- liftIO $ keyLocations g key
 	allremotes <- remotesByCost
 	remotes <- reposByUUID allremotes uuids
@@ -36,7 +37,7 @@ withKey key = do
 {- Cost Ordered list of remotes. -}
 remotesByCost :: Annex [Git.Repo]
 remotesByCost = do
-	g <- gitAnnex
+	g <- Annex.gitRepo
 	reposByCost $ Git.remotes g
 
 {- Orders a list of git repos by cost. -}
@@ -57,7 +58,7 @@ reposByCost l = do
  -}
 repoCost :: Git.Repo -> Annex Int
 repoCost r = do
-	g <- gitAnnex
+	g <- Annex.gitRepo
 	if ((length $ config g r) > 0)
 		then return $ read $ config g r
 		else if (Git.repoIsLocal r)
@@ -76,10 +77,10 @@ ensureGitConfigRead r = do
 	if (Map.null $ Git.configMap r)
 		then do
 			r' <- liftIO $ Git.configRead r
-			g <- gitAnnex
+			g <- Annex.gitRepo
 			let l = Git.remotes g
 			let g' = Git.remotesAdd g $ exchange l r'
-			gitAnnexChange g'
+			Annex.gitRepoChange g'
 			return r'
 		else return r
 	where 

Types.hs

@@ -0,0 +1,10 @@
+{- git-annex abstract data types -}
+
+module Types (
+	Annex,
+	AnnexState,
+	Key,
+	Backend
+) where
+
+import BackendTypes

UUID.hs

@@ -20,7 +20,8 @@ import List
 import System.Cmd.Utils
 import System.IO
 import qualified GitRepo as Git
-import AbstractTypes
+import Types
+import qualified Annex
 
 type UUID = String
 
@@ -45,22 +46,22 @@ getUUID r = do
 	where
 		configured r = Git.configGet r "annex.uuid" ""
 		cached r = do
-			g <- gitAnnex
+			g <- Annex.gitRepo
 			return $ Git.configGet g (configkey r) ""
 		configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-uuid"
 
 {- Make sure that the repo has an annex.uuid setting. -}
 prepUUID :: Annex ()
 prepUUID = do
-	g <- gitAnnex
+	g <- Annex.gitRepo
 	u <- getUUID g
 	if ("" == u)
 		then do
 			uuid <- genUUID
 			liftIO $ Git.run g ["config", configkey, uuid]
 			-- re-read git config and update the repo's state
-			u' <- liftIO $ Git.configRead g
-			gitAnnexChange u'
+			g' <- liftIO $ Git.configRead g
+			Annex.gitRepoChange g'
 			return ()
 		else return ()
 

git-annex.hs

@@ -6,8 +6,9 @@ import System.IO
 import System.Environment
 import Control.Exception
 import CmdLine
-import AbstractTypes
-import Annex
+import Types
+import Commands
+import qualified Annex
 
 main = do
 	args <- getArgs
@@ -30,7 +31,8 @@ tryRun state mode errnum oknum [] = do
 		then error $ (show errnum) ++ " failed ; " ++ show (oknum) ++ " ok"
 		else return ()
 tryRun state mode errnum oknum (f:fs) = do
-	result <- try (runAnnexState state (dispatch mode f))::IO (Either SomeException ((), AnnexState))
+	result <- try
+		(Annex.run state (dispatch mode f))::IO (Either SomeException ((), AnnexState))
 	case (result) of
 		Left err -> do
 			showErr err