code simplification thanks to applicative functors

This commit is contained in:
Joey Hess 2011-08-25 00:28:55 -04:00
parent 20259c2955
commit 678726c10c
15 changed files with 46 additions and 36 deletions

View file

@ -20,6 +20,7 @@ module Annex (
import Control.Monad.State
import Control.Monad.IO.Control
import Control.Applicative hiding (empty)
import qualified Git
import Git.Queue
@ -36,7 +37,9 @@ newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
Monad,
MonadIO,
MonadControlIO,
MonadState AnnexState
MonadState AnnexState,
Functor,
Applicative
)
-- internal state storage
@ -83,7 +86,7 @@ newState gitrepo = AnnexState
{- Create and returns an Annex state object for the specified git repo. -}
new :: Git.Repo -> IO AnnexState
new gitrepo = newState `liftM` Git.configRead gitrepo
new gitrepo = newState <$> Git.configRead gitrepo
{- performs an action in the Annex monad -}
run :: AnnexState -> Annex a -> IO (a, AnnexState)

View file

@ -20,6 +20,7 @@ module Branch (
import Control.Monad (when, unless, liftM)
import Control.Monad.State (liftIO)
import Control.Applicative ((<$>))
import System.FilePath
import System.Directory
import Data.String.Utils
@ -158,7 +159,7 @@ update = do
staged <- stageJournalFiles
refs <- siblingBranches
updated <- catMaybes `liftM` mapM updateRef refs
updated <- catMaybes <$> mapM updateRef refs
g <- Annex.gitRepo
unless (null updated && not staged) $ liftIO $
Git.commit g "update" fullname (fullname:updated)
@ -182,7 +183,7 @@ hasOrigin = refExists originname
{- Does the git-annex branch or a foo/git-annex branch exist? -}
hasSomeBranch :: Annex Bool
hasSomeBranch = liftM (not . null) siblingBranches
hasSomeBranch = not . null <$> siblingBranches
{- List of all git-annex branches, including the main one and any
- from remotes. -}
@ -323,7 +324,7 @@ getJournalFile file = do
{- List of journal files. -}
getJournalFiles :: Annex [FilePath]
getJournalFiles = liftM (map fileJournal) getJournalFilesRaw
getJournalFiles = map fileJournal <$> getJournalFilesRaw
getJournalFilesRaw :: Annex [FilePath]
getJournalFilesRaw = do

View file

@ -11,6 +11,7 @@ import Control.Monad.State (liftIO)
import System.Directory
import System.Posix.Files
import Control.Monad (filterM, liftM, when)
import Control.Applicative
import System.Path.WildMatch
import Text.Regex.PCRE.Light.Char8
import Data.List
@ -183,7 +184,7 @@ withNothing a [] = return [a]
withNothing _ _ = error "This command takes no parameters."
backendPairs :: CommandSeekBackendFiles
backendPairs a files = liftM (map a) $ Backend.chooseBackends files
backendPairs a files = map a <$> Backend.chooseBackends files
{- Filter out files those matching the exclude glob pattern,
- if it was specified. -}
@ -204,7 +205,7 @@ wildsRegex ws = compile regex []
{- filter out symlinks -}
notSymlink :: FilePath -> IO Bool
notSymlink f = liftM (not . isSymbolicLink) $ liftIO $ getSymbolicLinkStatus f
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
{- Descriptions of params used in usage messages. -}
paramRepeating :: String -> String
@ -271,4 +272,4 @@ preserveOrder orig new = collect orig new
- of git file list commands, that assumption tends to hold.
-}
runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
runPreserveOrder a files = liftM (preserveOrder files) (a files)
runPreserveOrder a files = preserveOrder files <$> a files

View file

@ -8,6 +8,7 @@
module Command.Migrate where
import Control.Monad.State (liftIO)
import Control.Applicative
import System.Posix.Files
import System.Directory
import System.FilePath
@ -39,7 +40,7 @@ start (file, b) = isAnnexed file $ \(key, oldbackend) -> do
next $ perform file key newbackend
else stop
where
choosebackend Nothing = return . head =<< Backend.orderedList
choosebackend Nothing = head <$> Backend.orderedList
choosebackend (Just backend) = return backend
{- Checks if a key is upgradable to a newer representation. -}

View file

@ -8,6 +8,7 @@
module Command.Status where
import Control.Monad.State
import Control.Applicative
import Data.Maybe
import System.IO
import Data.List
@ -112,12 +113,10 @@ total_annex_size = stat "total annex size" $
cachedKeysReferenced >>= keySizeSum
local_annex_keys :: Stat
local_annex_keys = stat "local annex keys" $
return . show . snd =<< cachedKeysPresent
local_annex_keys = stat "local annex keys" $ show . snd <$> cachedKeysPresent
total_annex_keys :: Stat
total_annex_keys = stat "total annex keys" $
return . show . snd =<< cachedKeysReferenced
total_annex_keys = stat "total annex keys" $ show . snd <$> cachedKeysReferenced
tmp_size :: Stat
tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
@ -126,8 +125,7 @@ bad_data_size :: Stat
bad_data_size = staleSize "bad keys size" gitAnnexBadDir
backend_usage :: Stat
backend_usage = stat "backend usage" $
return . usage =<< cachedKeysReferenced
backend_usage = stat "backend usage" $ usage <$> cachedKeysReferenced
where
usage (ks, _) = pp "" $ sort $ map swap $ splits ks
splits :: [Key] -> [(String, Integer)]

View file

@ -9,7 +9,7 @@ module Config where
import Data.Maybe
import Control.Monad.State (liftIO)
import Control.Monad (liftM)
import Control.Applicative
import System.Cmd.Utils
import qualified Git
@ -47,8 +47,8 @@ remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex
remoteCost :: Git.Repo -> Int -> Annex Int
remoteCost r def = do
cmd <- getConfig r "cost-command" ""
return . safeparse =<< if not $ null cmd
then liftM snd $ liftIO $ pipeFrom "sh" ["-c", cmd]
safeparse <$> if not $ null cmd
then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd]
else getConfig r "cost" ""
where
safeparse v

View file

@ -38,6 +38,7 @@ import System.IO
import System.Posix.IO
import System.Posix.Types
import System.Posix.Process
import Control.Applicative
import Control.Concurrent
import Control.Exception (finally)
import System.Exit
@ -136,7 +137,7 @@ encryptCipher (Cipher c) (KeyIds ks) = do
{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
decryptCipher :: RemoteConfig -> EncryptedCipher -> IO Cipher
decryptCipher _ (EncryptedCipher encipher _) =
return . Cipher =<< gpgPipeStrict decrypt encipher
Cipher <$> gpgPipeStrict decrypt encipher
where
decrypt = [ Param "--decrypt" ]

3
Git.hs
View file

@ -63,6 +63,7 @@ module Git (
) where
import Control.Monad (unless, when)
import Control.Applicative
import System.Directory
import System.FilePath
import System.Posix.Directory
@ -446,7 +447,7 @@ commit g message newref parentrefs = do
pipeWriteRead g (map Param $ ["commit-tree", tree] ++ ps) message
run g "update-ref" [Param newref, Param sha]
where
ignorehandle a = return . snd =<< a
ignorehandle a = snd <$> a
ps = concatMap (\r -> ["-p", r]) parentrefs
{- Reads null terminated output of a git command (as enabled by the -z

View file

@ -24,6 +24,7 @@ module LocationLog (
import System.FilePath
import Control.Monad (when)
import Control.Applicative
import Data.Maybe
import qualified Git
@ -49,7 +50,7 @@ keyLocations key = currentLog $ logFile key
{- Finds all keys that have location log information.
- (There may be duplicate keys in the list.) -}
loggedKeys :: Annex [Key]
loggedKeys = return . mapMaybe (logFileKey . takeFileName) =<< Branch.files
loggedKeys = mapMaybe (logFileKey . takeFileName) <$> Branch.files
{- The filename of the log file for a given key. -}
logFile :: Key -> String

View file

@ -28,6 +28,7 @@ import Data.Time
import System.Locale
import qualified Data.Map as Map
import Control.Monad.State (liftIO)
import Control.Applicative
import qualified Branch
import Types
@ -81,7 +82,7 @@ addLog file line = do
{- Reads a log file.
- Note that the LogLines returned may be in any order. -}
readLog :: FilePath -> Annex [LogLine]
readLog file = return . parseLog =<< Branch.get file
readLog file = parseLog <$> Branch.get file
parseLog :: String -> [LogLine]
parseLog s = filter parsable $ map read $ lines s

View file

@ -29,11 +29,12 @@ module Remote (
forceTrust
) where
import Control.Monad (filterM, liftM2)
import Control.Monad (filterM)
import Data.List
import qualified Data.Map as M
import Data.String.Utils
import Data.Maybe
import Control.Applicative
import Types
import Types.Remote
@ -111,10 +112,10 @@ nameToUUID "." = getUUID =<< Annex.gitRepo -- special case for current repo
nameToUUID n = do
res <- byName' n
case res of
Left e -> return . fromMaybe (error e) =<< byDescription
Left e -> fromMaybe (error e) <$> byDescription
Right r -> return $ uuid r
where
byDescription = return . M.lookup n . invertMap =<< uuidMap
byDescription = M.lookup n . invertMap <$> uuidMap
invertMap = M.fromList . map swap . M.toList
swap (a, b) = (b, a)
@ -124,10 +125,10 @@ prettyPrintUUIDs uuids = do
here <- getUUID =<< Annex.gitRepo
-- Show descriptions from the uuid log, falling back to remote names,
-- as some remotes may not be in the uuid log
m <- liftM2 M.union uuidMap $
return . M.fromList . map (\r -> (uuid r, name r)) =<< genList
m <- M.union <$> uuidMap <*> availMap
return $ unwords $ map (\u -> "\t" ++ prettify m u here ++ "\n") uuids
where
availMap = M.fromList . map (\r -> (uuid r, name r)) <$> genList
prettify m u here = base ++ ishere
where
base = if not $ null $ findlog m u
@ -147,7 +148,7 @@ remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
-}
keyPossibilities :: Key -> Annex [Remote Annex]
keyPossibilities key = return . fst =<< keyPossibilities' False key
keyPossibilities key = fst <$> keyPossibilities' False key
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
-

View file

@ -19,6 +19,7 @@ import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Char
import Control.Applicative
import qualified Branch
import Types
@ -40,7 +41,7 @@ configSet u c = do
{- Map of remotes by uuid containing key/value config maps. -}
readRemoteLog :: Annex (M.Map UUID RemoteConfig)
readRemoteLog = return . remoteLogParse =<< Branch.get remoteLog
readRemoteLog = remoteLogParse <$> Branch.get remoteLog
remoteLogParse :: String -> M.Map UUID RemoteConfig
remoteLogParse s =

View file

@ -11,6 +11,7 @@ import System.IO.Error (try)
import System.Directory
import Control.Monad.State (liftIO)
import Control.Monad (filterM, forM_, unless)
import Control.Applicative
import System.Posix.Files
import System.FilePath
import Data.String.Utils
@ -192,7 +193,7 @@ writeLog1 :: FilePath -> [LogLine] -> IO ()
writeLog1 file ls = viaTmp writeFile file (unlines $ map show ls)
readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catch (return . parseLog =<< readFileStrict file) (const $ return [])
readLog1 file = catch (parseLog <$> readFileStrict file) (const $ return [])
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
lookupFile1 file = do
@ -201,7 +202,7 @@ lookupFile1 file = do
Left _ -> return Nothing
Right l -> makekey l
where
getsymlink = return . takeFileName =<< readSymbolicLink file
getsymlink = takeFileName <$> readSymbolicLink file
makekey l = case maybeLookupBackendName bname of
Nothing -> do
unless (null kname || null bname ||

View file

@ -13,7 +13,7 @@ import System.FilePath
import System.Directory
import Data.List
import Data.Maybe
import Control.Monad (liftM2)
import Control.Applicative
{- Returns the parent directory of a path. Parent of / is "" -}
parentDir :: FilePath -> FilePath
@ -65,7 +65,7 @@ absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = liftM2 relPathDirToFile getCurrentDirectory (absPath f)
relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
{- Constructs a relative path from a directory to a file.
-

View file

@ -11,7 +11,7 @@ module Utility.Url (
get
) where
import Control.Monad (liftM)
import Control.Applicative
import Control.Monad.State (liftIO)
import qualified Network.Browser as Browser
import Network.HTTP
@ -64,7 +64,6 @@ request url requesttype = Browser.browse $ do
Browser.setErrHandler ignore
Browser.setOutHandler ignore
Browser.setAllowRedirects True
liftM snd $ Browser.request
(mkRequest requesttype url :: Request_String)
snd <$> Browser.request (mkRequest requesttype url :: Request_String)
where
ignore = const $ return ()