hello, liftM
This commit is contained in:
parent
208fb142d4
commit
dd0f662849
3 changed files with 12 additions and 26 deletions
4
Annex.hs
4
Annex.hs
|
@ -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.
|
||||||
-
|
-
|
||||||
|
|
28
Command.hs
28
Command.hs
|
@ -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
|
|
||||||
|
|
|
@ -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.
|
||||||
-
|
-
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue