hello, liftM

This commit is contained in:
Joey Hess 2011-02-19 17:00:40 -04:00
parent 208fb142d4
commit dd0f662849
3 changed files with 12 additions and 26 deletions

View file

@ -75,9 +75,7 @@ eval state action = evalStateT action state
{- Gets a value from the internal state, selected by the passed value {- Gets a value from the internal state, selected by the passed value
- constructor. -} - constructor. -}
getState :: (AnnexState -> a) -> Annex a getState :: (AnnexState -> a) -> Annex a
getState c = do getState c = liftM c get
state <- get
return (c state)
{- Applies a state mutation function to change the internal state. {- Applies a state mutation function to change the internal state.
- -

View file

@ -10,7 +10,7 @@ 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) import Control.Monad (filterM, liftM)
import System.Path.WildMatch import System.Path.WildMatch
import Text.Regex.PCRE.Light.Char8 import Text.Regex.PCRE.Light.Char8
import Data.List import Data.List
@ -110,15 +110,13 @@ withFilesInGit :: CommandSeekStrings
withFilesInGit a params = do withFilesInGit a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
files <- liftIO $ runPreserveOrder (Git.inRepo repo) params files <- liftIO $ runPreserveOrder (Git.inRepo repo) params
files' <- filterFiles files liftM (map a) $ filterFiles files
return $ map a files'
withAttrFilesInGit :: String -> CommandSeekAttrFiles withAttrFilesInGit :: String -> CommandSeekAttrFiles
withAttrFilesInGit attr a params = do withAttrFilesInGit attr a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
files <- liftIO $ runPreserveOrder (Git.inRepo repo) params files <- liftIO $ runPreserveOrder (Git.inRepo repo) params
files' <- filterFiles files files' <- filterFiles files
pairs <- liftIO $ Git.checkAttr repo attr files' liftM (map a) $ liftIO $ Git.checkAttr repo attr files'
return $ map a pairs
withBackendFilesInGit :: CommandSeekBackendFiles withBackendFilesInGit :: CommandSeekBackendFiles
withBackendFilesInGit a params = do withBackendFilesInGit a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
@ -128,8 +126,7 @@ withBackendFilesInGit a params = do
withFilesMissing :: CommandSeekStrings withFilesMissing :: CommandSeekStrings
withFilesMissing a params = do withFilesMissing a params = do
files <- liftIO $ filterM missing params files <- liftIO $ filterM missing params
files' <- filterFiles files liftM (map a) $ filterFiles files
return $ map a files'
where where
missing f = do missing f = do
e <- doesFileExist f e <- doesFileExist f
@ -148,8 +145,7 @@ withFilesToBeCommitted :: CommandSeekStrings
withFilesToBeCommitted a params = do withFilesToBeCommitted a params = do
repo <- Annex.gitRepo repo <- Annex.gitRepo
tocommit <- liftIO $ runPreserveOrder (Git.stagedFilesNotDeleted repo) params tocommit <- liftIO $ runPreserveOrder (Git.stagedFilesNotDeleted repo) params
tocommit' <- filterFiles tocommit liftM (map a) $ filterFiles tocommit
return $ map a tocommit'
withFilesUnlocked :: CommandSeekBackendFiles withFilesUnlocked :: CommandSeekBackendFiles
withFilesUnlocked = withFilesUnlocked' Git.typeChangedFiles withFilesUnlocked = withFilesUnlocked' Git.typeChangedFiles
withFilesUnlockedToBeCommitted :: CommandSeekBackendFiles withFilesUnlockedToBeCommitted :: CommandSeekBackendFiles
@ -172,9 +168,7 @@ withNothing a [] = return [a]
withNothing _ _ = return [] withNothing _ _ = return []
backendPairs :: CommandSeekBackendFiles backendPairs :: CommandSeekBackendFiles
backendPairs a files = do backendPairs a files = liftM (map a) $ Backend.chooseBackends files
pairs <- Backend.chooseBackends files
return $ map a pairs
{- Filter out files from the state directory, and those matching the {- Filter out files from the state directory, and those matching the
- exclude glob pattern, if it was specified. -} - exclude glob pattern, if it was specified. -}
@ -201,9 +195,7 @@ wildsRegex' (w:ws) c = wildsRegex' ws (c ++ "|" ++ wildToRegex w)
{- filter out symlinks -} {- filter out symlinks -}
notSymlink :: FilePath -> IO Bool notSymlink :: FilePath -> IO Bool
notSymlink f = do notSymlink f = liftM (not . isSymbolicLink) $ liftIO $ getSymbolicLinkStatus f
s <- liftIO $ getSymbolicLinkStatus f
return $ not $ isSymbolicLink s
{- Descriptions of params used in usage messages. -} {- Descriptions of params used in usage messages. -}
paramRepeating :: String -> String paramRepeating :: String -> String
@ -260,10 +252,8 @@ preserveOrder orig new = collect orig new
- its return list preserves order. - its return list preserves order.
- -
- This assumes that it's cheaper to call preserveOrder on the result, - This assumes that it's cheaper to call preserveOrder on the result,
- than it would be to run the action once with each param. In the case - 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. - of git file list commands, that assumption tends to hold.
-} -}
runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath] runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
runPreserveOrder a files = do runPreserveOrder a files = liftM (preserveOrder files) (a files)
r <- a files
return $ preserveOrder files r

View file

@ -38,6 +38,7 @@ import System.FilePath
import System.Directory import System.Directory
import Foreign (complement) import Foreign (complement)
import Data.List import Data.List
import Control.Monad (liftM2)
{- A version of hgetContents that is not lazy. Ensures file is {- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -} - all read before it gets closed. -}
@ -95,10 +96,7 @@ absPath file = do
- relPathCwdToDir "/tmp/foo/bar" == "" - relPathCwdToDir "/tmp/foo/bar" == ""
-} -}
relPathCwdToDir :: FilePath -> IO FilePath relPathCwdToDir :: FilePath -> IO FilePath
relPathCwdToDir dir = do relPathCwdToDir dir = liftM2 relPathDirToDir getCurrentDirectory (absPath dir)
cwd <- getCurrentDirectory
a <- absPath dir
return $ relPathDirToDir cwd a
{- Constructs a relative path from one directory to another. {- Constructs a relative path from one directory to another.
- -