code simplification thanks to applicative functors
This commit is contained in:
parent
20259c2955
commit
678726c10c
15 changed files with 46 additions and 36 deletions
7
Annex.hs
7
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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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)]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
3
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
13
Remote.hs
13
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.
|
||||
-
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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 ||
|
||||
|
|
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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 ()
|
||||
|
|
Loading…
Add table
Reference in a new issue