From 678726c10c13481c082743808a5188d28567e2b3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 25 Aug 2011 00:28:55 -0400 Subject: code simplification thanks to applicative functors --- Annex.hs | 7 +++++-- Branch.hs | 7 ++++--- Command.hs | 7 ++++--- Command/Migrate.hs | 3 ++- Command/Status.hs | 10 ++++------ Config.hs | 6 +++--- Crypto.hs | 3 ++- Git.hs | 3 ++- LocationLog.hs | 3 ++- PresenceLog.hs | 3 ++- Remote.hs | 13 +++++++------ RemoteLog.hs | 3 ++- Upgrade/V1.hs | 5 +++-- Utility/Path.hs | 4 ++-- Utility/Url.hs | 5 ++--- 15 files changed, 46 insertions(+), 36 deletions(-) diff --git a/Annex.hs b/Annex.hs index 07316bd37..287aed875 100644 --- a/Annex.hs +++ b/Annex.hs @@ -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) diff --git a/Branch.hs b/Branch.hs index d5bfe1b09..5008b2e20 100644 --- a/Branch.hs +++ b/Branch.hs @@ -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 diff --git a/Command.hs b/Command.hs index d3c1640ee..21c50f9c0 100644 --- a/Command.hs +++ b/Command.hs @@ -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 diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 25227ae16..6ad7e239c 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -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. -} diff --git a/Command/Status.hs b/Command/Status.hs index aef4df232..5c82744b1 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -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)] diff --git a/Config.hs b/Config.hs index 12f648047..b4f4c0b92 100644 --- a/Config.hs +++ b/Config.hs @@ -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 diff --git a/Crypto.hs b/Crypto.hs index ed29747aa..d789b4455 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -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" ] diff --git a/Git.hs b/Git.hs index 7155b2634..ab43504e1 100644 --- a/Git.hs +++ b/Git.hs @@ -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 diff --git a/LocationLog.hs b/LocationLog.hs index 768483fa1..fa660c8b6 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -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 diff --git a/PresenceLog.hs b/PresenceLog.hs index ccb75ff5b..e0c872997 100644 --- a/PresenceLog.hs +++ b/PresenceLog.hs @@ -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 diff --git a/Remote.hs b/Remote.hs index 1a5006f6f..2c883f1a8 100644 --- a/Remote.hs +++ b/Remote.hs @@ -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. - diff --git a/RemoteLog.hs b/RemoteLog.hs index 69a82f498..620c0d875 100644 --- a/RemoteLog.hs +++ b/RemoteLog.hs @@ -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 = diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index b4567a0b7..9c3fd9959 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -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 || diff --git a/Utility/Path.hs b/Utility/Path.hs index 517c175bc..9b8041dad 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -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. - diff --git a/Utility/Url.hs b/Utility/Url.hs index 69b53c34c..f678720ed 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -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 () -- cgit v1.2.3