diff options
author | Joey Hess <joey@kitenet.net> | 2011-01-25 21:49:04 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-01-25 21:49:04 -0400 |
commit | 082b022f9ae56b1446b6607cf7851cd4f1d4f904 (patch) | |
tree | 4712d36e841bca351c9aa68a911c4fb82188b4c1 | |
parent | 109a719b03dbeb70eb317be17f7e18567efa9dac (diff) |
successfully split Annex and AnnexState out of TypeInternals
-rw-r--r-- | Annex.hs | 91 | ||||
-rw-r--r-- | Backend.hs | 10 | ||||
-rw-r--r-- | Backend/File.hs | 1 | ||||
-rw-r--r-- | Backend/SHA1.hs | 1 | ||||
-rw-r--r-- | Backend/URL.hs | 1 | ||||
-rw-r--r-- | Backend/WORM.hs | 1 | ||||
-rw-r--r-- | CmdLine.hs | 4 | ||||
-rw-r--r-- | Options.hs | 8 | ||||
-rw-r--r-- | Remotes.hs | 2 | ||||
-rw-r--r-- | TypeInternals.hs | 21 | ||||
-rw-r--r-- | Types.hs | 6 | ||||
-rw-r--r-- | test.hs | 3 |
12 files changed, 72 insertions, 77 deletions
@@ -6,18 +6,20 @@ -} module Annex ( + Annex, + AnnexState(..), + getState, new, run, eval, gitRepo, gitRepoChange, - backends, backendsChange, - supportedBackends, + FlagName, + Flag(..), flagIsSet, flagChange, flagGet, - Flag(..), queue, queueGet, queueRun, @@ -29,19 +31,38 @@ import qualified Data.Map as M import qualified GitRepo as Git import qualified GitQueue -import Types -import qualified TypeInternals as Internals +import qualified TypeInternals + +-- git-annex's monad +type Annex = StateT AnnexState IO + +-- internal state storage +data AnnexState = AnnexState { + repo :: Git.Repo, + backends :: [TypeInternals.Backend Annex], + supportedBackends :: [TypeInternals.Backend Annex], + flags :: M.Map FlagName Flag, + repoqueue :: GitQueue.Queue, + quiet :: Bool +} deriving (Show) + +-- command-line flags +type FlagName = String +data Flag = + FlagBool Bool | + FlagString String + deriving (Eq, Read, Show) {- Create and returns an Annex state object for the specified git repo. -} -new :: Git.Repo -> [Backend Annex] -> IO AnnexState +new :: Git.Repo -> [TypeInternals.Backend Annex] -> IO AnnexState new gitrepo allbackends = do - let s = Internals.AnnexState { - Internals.repo = gitrepo, - Internals.backends = [], - Internals.supportedBackends = allbackends, - Internals.flags = M.empty, - Internals.repoqueue = GitQueue.empty, - Internals.quiet = False + let s = AnnexState { + repo = gitrepo, + backends = [], + supportedBackends = allbackends, + flags = M.empty, + repoqueue = GitQueue.empty, + quiet = False } (_,s') <- Annex.run s prep return s' @@ -57,41 +78,33 @@ run state action = runStateT action state eval :: AnnexState -> Annex a -> IO a eval state action = evalStateT action state +{- gets a value from the internal Annex state -} +getState :: (AnnexState -> a) -> Annex a +getState a = do + state <- get + return (a state) + {- Returns the git repository being acted on -} gitRepo :: Annex Git.Repo -gitRepo = do - state <- get - return (Internals.repo state) +gitRepo = getState repo {- Changes the git repository being acted on. -} gitRepoChange :: Git.Repo -> Annex () gitRepoChange r = do state <- get - put state { Internals.repo = r } - -{- Returns the backends being used. -} -backends :: Annex [Backend Annex] -backends = do - state <- get - return (Internals.backends state) + put state { repo = r } {- Sets the backends to use. -} -backendsChange :: [Backend Annex] -> Annex () +backendsChange :: [TypeInternals.Backend Annex] -> Annex () backendsChange b = do state <- get - put state { Internals.backends = b } - -{- Returns the full list of supported backends. -} -supportedBackends :: Annex [Backend Annex] -supportedBackends = do - state <- get - return (Internals.supportedBackends state) + put state { backends = b } {- Return True if a Bool flag is set. -} flagIsSet :: FlagName -> Annex Bool flagIsSet name = do state <- get - case (M.lookup name $ Internals.flags state) of + case (M.lookup name $ flags state) of Just (FlagBool True) -> return True _ -> return False @@ -99,13 +112,13 @@ flagIsSet name = do flagChange :: FlagName -> Flag -> Annex () flagChange name val = do state <- get - put state { Internals.flags = M.insert name val $ Internals.flags state } + put state { flags = M.insert name val $ flags state } {- Gets the value of a String flag (or "" if there is no such String flag) -} flagGet :: FlagName -> Annex String flagGet name = do state <- get - case (M.lookup name $ Internals.flags state) of + case (M.lookup name $ flags state) of Just (FlagString s) -> return s _ -> return "" @@ -113,23 +126,23 @@ flagGet name = do queue :: String -> [String] -> FilePath -> Annex () queue command params file = do state <- get - let q = Internals.repoqueue state - put state { Internals.repoqueue = GitQueue.add q command params file } + let q = repoqueue state + put state { repoqueue = GitQueue.add q command params file } {- Returns the queue. -} queueGet :: Annex GitQueue.Queue queueGet = do state <- get - return (Internals.repoqueue state) + return (repoqueue state) {- Runs (and empties) the queue. -} queueRun :: Annex () queueRun = do state <- get - let q = Internals.repoqueue state + let q = repoqueue state g <- gitRepo liftIO $ GitQueue.run g q - put state { Internals.repoqueue = GitQueue.empty } + put state { repoqueue = GitQueue.empty } {- Changes a git config setting in both internal state and .git/config -} setConfig :: String -> String -> Annex () diff --git a/Backend.hs b/Backend.hs index caf50005a..551c041a8 100644 --- a/Backend.hs +++ b/Backend.hs @@ -44,11 +44,11 @@ import Messages {- List of backends in the order to try them when storing a new key. -} list :: Annex [Backend Annex] list = do - l <- Annex.backends -- list is cached here + l <- Annex.getState Annex.backends -- list is cached here if not $ null l then return l else do - bs <- Annex.supportedBackends + bs <- Annex.getState Annex.supportedBackends g <- Annex.gitRepo let defaults = parseBackendList bs $ Git.configGet g "annex.backends" "" backendflag <- Annex.flagGet "backend" @@ -121,7 +121,7 @@ fsckKey backend key numcopies = (Internals.fsckKey backend) key numcopies - by examining what the file symlinks to. -} lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile file = do - bs <- Annex.supportedBackends + bs <- Annex.getState Annex.supportedBackends tl <- liftIO $ try getsymlink case tl of Left _ -> return Nothing @@ -150,12 +150,12 @@ lookupFile file = do chooseBackends :: [FilePath] -> Annex [(FilePath, Maybe (Backend Annex))] chooseBackends fs = do g <- Annex.gitRepo - bs <- Annex.supportedBackends + bs <- Annex.getState Annex.supportedBackends pairs <- liftIO $ Git.checkAttr g "annex.backend" fs return $ map (\(f,b) -> (f, maybeLookupBackendName bs b)) pairs {- Returns the backend to use for a key. -} keyBackend :: Key -> Annex (Backend Annex) keyBackend key = do - bs <- Annex.supportedBackends + bs <- Annex.getState Annex.supportedBackends return $ lookupBackendName bs $ backendName key diff --git a/Backend/File.hs b/Backend/File.hs index c8ddd5938..962d09909 100644 --- a/Backend/File.hs +++ b/Backend/File.hs @@ -24,6 +24,7 @@ import qualified Remotes import qualified GitRepo as Git import Content import qualified Annex +import Types import UUID import Messages diff --git a/Backend/SHA1.hs b/Backend/SHA1.hs index e665e5da7..be41264b0 100644 --- a/Backend/SHA1.hs +++ b/Backend/SHA1.hs @@ -19,6 +19,7 @@ import Messages import qualified Annex import Locations import Content +import Types backend :: Backend Annex backend = Backend.File.backend { diff --git a/Backend/URL.hs b/Backend/URL.hs index 8ed354aed..d67b7db84 100644 --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -10,6 +10,7 @@ module Backend.URL (backend) where import Control.Monad.State (liftIO) import Data.String.Utils +import Types import TypeInternals import Utility import Messages diff --git a/Backend/WORM.hs b/Backend/WORM.hs index cd4254e2b..011018393 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -20,6 +20,7 @@ import Locations import qualified Annex import Content import Messages +import Types backend :: Backend Annex backend = Backend.File.backend { diff --git a/CmdLine.hs b/CmdLine.hs index 6772282c5..39dd61e99 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -78,9 +78,9 @@ usage header cmds options = - (but explicitly thrown errors terminate the whole command). - Runs shutdown and propigates an overall error status at the end. -} -tryRun :: AnnexState -> [Annex Bool] -> IO () +tryRun :: Annex.AnnexState -> [Annex Bool] -> IO () tryRun state actions = tryRun' state 0 actions -tryRun' :: AnnexState -> Integer -> [Annex Bool] -> IO () +tryRun' :: Annex.AnnexState -> Integer -> [Annex Bool] -> IO () tryRun' state errnum (a:as) = do result <- try $ Annex.run state a case result of diff --git a/Options.hs b/Options.hs index 5f367c9dd..2d4bb85fb 100644 --- a/Options.hs +++ b/Options.hs @@ -18,10 +18,10 @@ import Command -} type Option = OptDescr (Annex ()) -storeOptBool :: FlagName -> Bool -> Annex () -storeOptBool name val = Annex.flagChange name $ FlagBool val -storeOptString :: FlagName -> String -> Annex () -storeOptString name val = Annex.flagChange name $ FlagString val +storeOptBool :: Annex.FlagName -> Bool -> Annex () +storeOptBool name val = Annex.flagChange name $ Annex.FlagBool val +storeOptString :: Annex.FlagName -> String -> Annex () +storeOptString name val = Annex.flagChange name $ Annex.FlagString val commonOptions :: [Option] commonOptions = diff --git a/Remotes.hs b/Remotes.hs index 9004b33d0..e5aa80e1c 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -105,7 +105,7 @@ readConfigs = do let todo = cheap ++ doexpensive unless (null todo) $ do _ <- mapM tryGitConfigRead todo - Annex.flagChange "remotesread" $ FlagBool True + Annex.flagChange "remotesread" $ Annex.FlagBool True where cachedUUID r = do u <- getUUID r diff --git a/TypeInternals.hs b/TypeInternals.hs index 99f304973..abafe8711 100644 --- a/TypeInternals.hs +++ b/TypeInternals.hs @@ -17,27 +17,6 @@ import Test.QuickCheck import qualified GitRepo as Git import qualified GitQueue --- command-line flags -type FlagName = String -data Flag = - FlagBool Bool | - FlagString String - 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 Annex], - supportedBackends :: [Backend Annex], - flags :: M.Map FlagName Flag, - repoqueue :: GitQueue.Queue, - quiet :: Bool -} deriving (Show) - --- git-annex's monad -type Annex = StateT AnnexState IO - -- annexed filenames are mapped through a backend into keys type KeyName = String type BackendName = String @@ -7,14 +7,12 @@ module Types ( Annex, - AnnexState, Backend, Key, genKey, backendName, - keyName, - FlagName, - Flag(..) + keyName ) where import TypeInternals +import Annex @@ -28,6 +28,7 @@ import qualified GitRepo as Git import qualified Locations import qualified Utility import qualified TypeInternals +import qualified Types import qualified GitAnnex import qualified LocationLog import qualified UUID @@ -416,7 +417,7 @@ git_annex command params = do -- Runs an action in the current annex. Note that shutdown actions -- are not run; this should only be used for actions that query state. -annexeval :: TypeInternals.Annex a -> IO a +annexeval :: Types.Annex a -> IO a annexeval a = do g <- Git.repoFromCwd g' <- Git.configRead g |