better types

This commit is contained in:
Joey Hess 2010-11-01 20:03:21 -04:00
parent 1f9996f742
commit f0bf94f760

View file

@ -26,20 +26,21 @@ import Types
import Core
import qualified Remotes
{- A subcommand runs in four stages. Each stage can return the next stage
- to run.
{- A subcommand runs in four stages.
-
- 0. The parse stage takes the parameters passed to the subcommand,
- 0. The seek stage takes the parameters passed to the subcommand,
- looks through the repo to find the ones that are relevant
- to that subcommand (ie, new files to add), and returns a list of
- start stage actions to run. -}
type SubCmdParseStrings = (String -> SubCmdPerform) -> SubCmdStart
type SubCmdParseBackendFiles = ((FilePath, Maybe Backend) -> SubCmdPerform) -> SubCmdStart
- to that subcommand (ie, new files to add), and generates
- a start stage action. -}
type SubCmdSeekStrings = SubCmdStartString -> SubCmdSeek
type SubCmdSeekBackendFiles = SubCmdStartBackendFile -> SubCmdSeek
type SubCmdSeek = [String] -> Annex [SubCmdPerform]
{- 1. The start stage is run before anything is printed about the
- subcommand, is passed some input, and can early abort it
- if the input does not make sense. It should run quickly and
- should not modify Annex state. -}
type SubCmdStart = [String] -> Annex [SubCmdPerform]
type SubCmdStartString = String -> SubCmdPerform
type SubCmdStartBackendFile = (FilePath, Maybe Backend) -> SubCmdPerform
{- 2. The perform stage is run after a message is printed about the subcommand
- being run, and it should be where the bulk of the work happens. -}
type SubCmdPerform = Annex (Maybe SubCmdCleanup)
@ -51,7 +52,7 @@ type SubCmdStatus = Annex Bool
data SubCommand = SubCommand {
subcmdname :: String,
subcmdparams :: String,
subcmdparse :: SubCmdStart,
subcmdseek :: SubCmdSeek,
subcmddesc :: String
}
subCmds :: [SubCommand]
@ -127,8 +128,8 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
{- Prepares a set of actions to run to perform a subcommand, based on
- the parameters passed to it. -}
prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool]
prepSubCmd SubCommand { subcmdparse = parse } state params = do
list <- Annex.eval state $ parse params
prepSubCmd SubCommand { subcmdseek = seek } state params = do
list <- Annex.eval state $ seek params
return $ map (\a -> doSubCmd a) list
{- Runs a subcommand through the start, perform and cleanup stages -}
@ -153,21 +154,21 @@ doSubCmd start = do
showEndFail
return False
{- These functions parse a user's parameters into a list of SubCmdPerform
actions to perform. -}
withFilesNotInGit :: SubCmdParseBackendFiles
{- These functions find appropriate files or other things based on a
user's parameters. -}
withFilesNotInGit :: SubCmdSeekBackendFiles
withFilesNotInGit a params = do
repo <- Annex.gitRepo
files <- liftIO $ mapM (Git.notInRepo repo) params
let files' = foldl (++) [] files
pairs <- Backend.chooseBackends files'
return $ map a $ filter (\(f,_) -> notState f) pairs
withFilesInGit :: SubCmdParseStrings
withFilesInGit :: SubCmdSeekStrings
withFilesInGit a params = do
repo <- Annex.gitRepo
files <- liftIO $ mapM (Git.inRepo repo) params
return $ map a $ filter notState $ foldl (++) [] files
withFilesMissing :: SubCmdParseStrings
withFilesMissing :: SubCmdSeekStrings
withFilesMissing a params = do
files <- liftIO $ filterM missing params
return $ map a $ filter notState files
@ -175,17 +176,17 @@ withFilesMissing a params = do
missing f = do
e <- doesFileExist f
return $ not e
withDescription :: SubCmdParseStrings
withDescription :: SubCmdSeekStrings
withDescription a params = do
return $ [a $ unwords params]
withFilesToBeCommitted :: SubCmdParseStrings
withFilesToBeCommitted :: SubCmdSeekStrings
withFilesToBeCommitted a params = do
repo <- Annex.gitRepo
files <- liftIO $ mapM (Git.stagedFiles repo) params
return $ map a $ filter notState $ foldl (++) [] files
withKeys :: SubCmdParseStrings
withKeys :: SubCmdSeekStrings
withKeys a params = return $ map a params
withTempFile :: SubCmdParseStrings
withTempFile :: SubCmdSeekStrings
withTempFile a params = return $ map a params
{- filter out files from the state directory -}
@ -218,7 +219,7 @@ parseCmd argv state = do
{- The add subcommand 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. -}
addStart :: (FilePath, Maybe Backend) -> SubCmdPerform
addStart :: SubCmdStartBackendFile
addStart pair@(file, _) = notAnnexed file $ do
s <- liftIO $ getSymbolicLinkStatus file
if ((isSymbolicLink s) || (not $ isRegularFile s))
@ -245,7 +246,7 @@ addCleanup file key = do
return True
{- The unannex subcommand undoes an add. -}
unannexStart :: FilePath -> SubCmdPerform
unannexStart :: SubCmdStartString
unannexStart file = isAnnexed file $ \(key, backend) -> do
showStart "unannex" file
return $ Just $ unannexPerform file key backend
@ -270,7 +271,7 @@ unannexCleanup file key = do
return True
{- Gets an annexed file from one of the backends. -}
getStart :: FilePath -> SubCmdPerform
getStart :: SubCmdStartString
getStart file = isAnnexed file $ \(key, backend) -> do
inannex <- inAnnex key
if (inannex)
@ -287,7 +288,7 @@ getPerform key backend = do
{- Indicates a file's content is not wanted anymore, and should be removed
- if it's safe to do so. -}
dropStart :: FilePath -> SubCmdPerform
dropStart :: SubCmdStartString
dropStart file = isAnnexed file $ \(key, backend) -> do
inbackend <- Backend.hasKey key
if (not inbackend)
@ -314,7 +315,7 @@ dropCleanup key = do
else return True
{- Drops cached content for a key. -}
dropKeyStart :: String -> SubCmdPerform
dropKeyStart :: SubCmdStartString
dropKeyStart keyname = do
backends <- Backend.list
let key = genKey (backends !! 0) keyname
@ -339,7 +340,7 @@ dropKeyCleanup key = do
return True
{- Sets cached content for a key. -}
setKeyStart :: FilePath -> SubCmdPerform
setKeyStart :: SubCmdStartString
setKeyStart tmpfile = do
keyname <- Annex.flagGet "key"
when (null keyname) $ error "please specify the key with --key"
@ -361,7 +362,7 @@ setKeyCleanup key = do
return True
{- Fixes the symlink to an annexed file. -}
fixStart :: FilePath -> SubCmdPerform
fixStart :: SubCmdStartString
fixStart file = isAnnexed file $ \(key, _) -> do
link <- calcGitLink file key
l <- liftIO $ readSymbolicLink file
@ -382,7 +383,7 @@ fixCleanup file = do
return True
{- Stores description for the repository etc. -}
initStart :: String -> SubCmdPerform
initStart :: SubCmdStartString
initStart description = do
when (null description) $ error $
"please specify a description of this repository\n" ++ usage
@ -405,7 +406,7 @@ initCleanup = do
return True
{- Adds a file pointing at a manually-specified key -}
fromKeyStart :: FilePath -> SubCmdPerform
fromKeyStart :: SubCmdStartString
fromKeyStart file = do
keyname <- Annex.flagGet "key"
when (null keyname) $ error "please specify the key with --key"
@ -432,7 +433,7 @@ fromKeyCleanup file = do
-
- This only operates on the cached file content; it does not involve
- moving data in the key-value backend. -}
moveStart :: FilePath -> SubCmdPerform
moveStart :: SubCmdStartString
moveStart file = do
fromName <- Annex.flagGet "fromrepository"
toName <- Annex.flagGet "torepository"
@ -453,7 +454,7 @@ moveStart file = do
- A file's content can be moved even if there are insufficient copies to
- allow it to be dropped.
-}
moveToStart :: FilePath -> SubCmdPerform
moveToStart :: SubCmdStartString
moveToStart file = isAnnexed file $ \(key, _) -> do
ishere <- inAnnex key
if (not ishere)
@ -503,7 +504,7 @@ moveToCleanup remote key tmpfile = do
- If the current repository already has the content, it is still removed
- from the other repository.
-}
moveFromStart :: FilePath -> SubCmdPerform
moveFromStart :: SubCmdStartString
moveFromStart file = isAnnexed file $ \(key, _) -> do
remote <- Remotes.commandLineRemote
l <- Remotes.keyPossibilities key