reorg
This commit is contained in:
parent
6e80f19514
commit
dcded89129
2 changed files with 38 additions and 41 deletions
52
Command.hs
52
Command.hs
|
@ -1,6 +1,6 @@
|
||||||
{- git-annex command infrastructure
|
{- git-annex command infrastructure
|
||||||
-
|
-
|
||||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
|
||||||
-
|
-
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
@ -10,9 +10,8 @@ module Command where
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import Control.Monad (filterM, liftM, when)
|
import Control.Monad (filterM, liftM)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
|
@ -22,6 +21,8 @@ import qualified Annex
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Git.LsFiles as LsFiles
|
import qualified Git.LsFiles as LsFiles
|
||||||
import Utility
|
import Utility
|
||||||
|
import Utility.Conditional
|
||||||
|
import Utility.Path
|
||||||
import Types.Key
|
import Types.Key
|
||||||
import Trust
|
import Trust
|
||||||
import LocationLog
|
import LocationLog
|
||||||
|
@ -75,9 +76,8 @@ stop = return Nothing
|
||||||
{- Prepares a list of actions to run to perform a command, based on
|
{- Prepares a list of actions to run to perform a command, based on
|
||||||
- the parameters passed to it. -}
|
- the parameters passed to it. -}
|
||||||
prepCommand :: Command -> [String] -> Annex [Annex Bool]
|
prepCommand :: Command -> [String] -> Annex [Annex Bool]
|
||||||
prepCommand Command { cmdseek = seek } params = do
|
prepCommand Command { cmdseek = seek } params =
|
||||||
lists <- mapM (\s -> s params) seek
|
return . map doCommand . concat =<< mapM (\s -> s params) seek
|
||||||
return $ map doCommand $ concat lists
|
|
||||||
|
|
||||||
{- Runs a command through the start, perform and cleanup stages -}
|
{- Runs a command through the start, perform and cleanup stages -}
|
||||||
doCommand :: CommandStart -> CommandCleanup
|
doCommand :: CommandStart -> CommandCleanup
|
||||||
|
@ -86,11 +86,9 @@ doCommand = start
|
||||||
start = stage $ maybe success perform
|
start = stage $ maybe success perform
|
||||||
perform = stage $ maybe failure cleanup
|
perform = stage $ maybe failure cleanup
|
||||||
cleanup = stage $ \r -> showEndResult r >> return r
|
cleanup = stage $ \r -> showEndResult r >> return r
|
||||||
stage a b = b >>= a
|
stage = (=<<)
|
||||||
success = return True
|
success = return True
|
||||||
failure = do
|
failure = showEndFail >> return False
|
||||||
showEndFail
|
|
||||||
return False
|
|
||||||
|
|
||||||
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
|
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
|
||||||
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
|
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
|
||||||
|
@ -100,13 +98,12 @@ isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file
|
||||||
|
|
||||||
notBareRepo :: Annex a -> Annex a
|
notBareRepo :: Annex a -> Annex a
|
||||||
notBareRepo a = do
|
notBareRepo a = do
|
||||||
g <- Annex.gitRepo
|
whenM (Git.repoIsLocalBare <$> Annex.gitRepo) $
|
||||||
when (Git.repoIsLocalBare g) $
|
|
||||||
error "You cannot run this subcommand in a bare repository."
|
error "You cannot run this subcommand in a bare repository."
|
||||||
a
|
a
|
||||||
|
|
||||||
{- These functions find appropriate files or other things based on a
|
{- These functions find appropriate files or other things based on a
|
||||||
user's parameters, and run a specified action on them. -}
|
user's parameters, and prepare actions operating on them. -}
|
||||||
withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
|
withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
|
||||||
withFilesInGit a params = do
|
withFilesInGit a params = do
|
||||||
repo <- Annex.gitRepo
|
repo <- Annex.gitRepo
|
||||||
|
@ -170,7 +167,7 @@ runFiltered a fs = runFilteredGen a id fs
|
||||||
backendPairs :: (BackendFile -> CommandStart) -> CommandSeek
|
backendPairs :: (BackendFile -> CommandStart) -> CommandSeek
|
||||||
backendPairs a fs = runFilteredGen a snd (Backend.chooseBackends fs)
|
backendPairs a fs = runFilteredGen a snd (Backend.chooseBackends fs)
|
||||||
|
|
||||||
runFilteredGen :: (a1 -> Annex (Maybe a)) -> (a1 -> FilePath) -> Annex [a1] -> Annex [Annex (Maybe a)]
|
runFilteredGen :: (b -> Annex (Maybe a)) -> (b -> FilePath) -> Annex [b] -> Annex [Annex (Maybe a)]
|
||||||
runFilteredGen a d fs = do
|
runFilteredGen a d fs = do
|
||||||
matcher <- Limit.getMatcher
|
matcher <- Limit.getMatcher
|
||||||
liftM (map $ proc matcher) fs
|
liftM (map $ proc matcher) fs
|
||||||
|
@ -228,33 +225,6 @@ cmdlineKey = do
|
||||||
nokey = error "please specify the key with --key"
|
nokey = error "please specify the key with --key"
|
||||||
badkey = error "bad key"
|
badkey = error "bad key"
|
||||||
|
|
||||||
{- Given an original list of files, and an expanded list derived from it,
|
|
||||||
- ensures that the original list's ordering is preserved.
|
|
||||||
-
|
|
||||||
- The input list may contain a directory, like "dir" or "dir/". Any
|
|
||||||
- items in the expanded list that are contained in that directory will
|
|
||||||
- appear at the same position as it did in the input list.
|
|
||||||
-}
|
|
||||||
preserveOrder :: [FilePath] -> [FilePath] -> [FilePath]
|
|
||||||
-- optimisation, only one item in original list, so no reordering needed
|
|
||||||
preserveOrder [_] new = new
|
|
||||||
preserveOrder orig new = collect orig new
|
|
||||||
where
|
|
||||||
collect [] n = n
|
|
||||||
collect [_] n = n -- optimisation
|
|
||||||
collect (l:ls) n = found ++ collect ls rest
|
|
||||||
where (found, rest)=partition (l `dirContains`) n
|
|
||||||
|
|
||||||
{- Runs an action that takes a list of FilePaths, and ensures that
|
|
||||||
- its return list preserves order.
|
|
||||||
-
|
|
||||||
- This assumes that it's cheaper to call preserveOrder on the result,
|
|
||||||
- than it would be to run the action separately with each param. In the case
|
|
||||||
- of git file list commands, that assumption tends to hold.
|
|
||||||
-}
|
|
||||||
runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
|
|
||||||
runPreserveOrder a files = preserveOrder files <$> a files
|
|
||||||
|
|
||||||
{- Used for commands that have an auto mode that checks the number of known
|
{- Used for commands that have an auto mode that checks the number of known
|
||||||
- copies of a key.
|
- copies of a key.
|
||||||
-
|
-
|
||||||
|
|
|
@ -90,3 +90,30 @@ prop_relPathDirToFile_basics from to
|
||||||
| otherwise = not (null r)
|
| otherwise = not (null r)
|
||||||
where
|
where
|
||||||
r = relPathDirToFile from to
|
r = relPathDirToFile from to
|
||||||
|
|
||||||
|
{- Given an original list of files, and an expanded list derived from it,
|
||||||
|
- ensures that the original list's ordering is preserved.
|
||||||
|
-
|
||||||
|
- The input list may contain a directory, like "dir" or "dir/". Any
|
||||||
|
- items in the expanded list that are contained in that directory will
|
||||||
|
- appear at the same position as it did in the input list.
|
||||||
|
-}
|
||||||
|
preserveOrder :: [FilePath] -> [FilePath] -> [FilePath]
|
||||||
|
-- optimisation, only one item in original list, so no reordering needed
|
||||||
|
preserveOrder [_] new = new
|
||||||
|
preserveOrder orig new = collect orig new
|
||||||
|
where
|
||||||
|
collect [] n = n
|
||||||
|
collect [_] n = n -- optimisation
|
||||||
|
collect (l:ls) n = found ++ collect ls rest
|
||||||
|
where (found, rest)=partition (l `dirContains`) n
|
||||||
|
|
||||||
|
{- Runs an action that takes a list of FilePaths, and ensures that
|
||||||
|
- its return list preserves order.
|
||||||
|
-
|
||||||
|
- This assumes that it's cheaper to call preserveOrder on the result,
|
||||||
|
- than it would be to run the action separately with each param. In the case
|
||||||
|
- of git file list commands, that assumption tends to hold.
|
||||||
|
-}
|
||||||
|
runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
|
||||||
|
runPreserveOrder a files = preserveOrder files <$> a files
|
||||||
|
|
Loading…
Reference in a new issue