expose Control.Monad.join

I think I've been looking for that function for some time.
Ie, I remember wanting to collapse Just Nothing to Nothing.
This commit is contained in:
Joey Hess 2013-04-22 20:24:53 -04:00
parent 2a84deb271
commit 8a2d1988d3
19 changed files with 30 additions and 32 deletions

View file

@ -30,7 +30,7 @@ import Utility.Base64
- refs, per git-check-ref-format. - refs, per git-check-ref-format.
-} -}
toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
toTaggedBranch u info b = Git.Ref $ join "/" $ catMaybes toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
[ Just "refs/synced" [ Just "refs/synced"
, Just $ fromUUID u , Just $ fromUUID u
, toB64 <$> info , toB64 <$> info

View file

@ -105,11 +105,11 @@ removeAuthorizedKeys rsynconly dir pubkey = do
- present. - present.
-} -}
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
addAuthorizedKeysCommand rsynconly dir pubkey = join "&&" addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
[ "mkdir -p ~/.ssh" [ "mkdir -p ~/.ssh"
, join "; " , intercalate "; "
[ "if [ ! -e " ++ wrapper ++ " ]" [ "if [ ! -e " ++ wrapper ++ " ]"
, "then (" ++ join ";" (map echoval script) ++ ") > " ++ wrapper , "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper
, "fi" , "fi"
] ]
, "chmod 700 " ++ wrapper , "chmod 700 " ++ wrapper
@ -217,7 +217,7 @@ mangleSshHostName :: SshData -> String
mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata) mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
++ "-" ++ filter safe extra ++ "-" ++ filter safe extra
where where
extra = join "_" $ map T.unpack $ catMaybes extra = intercalate "_" $ map T.unpack $ catMaybes
[ sshUserName sshdata [ sshUserName sshdata
, Just $ sshDirectory sshdata , Just $ sshDirectory sshdata
] ]
@ -229,7 +229,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
{- Extracts the real hostname from a mangled ssh hostname. -} {- Extracts the real hostname from a mangled ssh hostname. -}
unMangleSshHostName :: String -> String unMangleSshHostName :: String -> String
unMangleSshHostName h = case split "-" h of unMangleSshHostName h = case split "-" h of
("git":"annex":rest) -> join "-" (beginning rest) ("git":"annex":rest) -> intercalate "-" (beginning rest)
_ -> h _ -> h
{- Does ssh have known_hosts data for a hostname? -} {- Does ssh have known_hosts data for a hostname? -}

View file

@ -205,7 +205,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
, rsyncOnly = status == UsableRsyncServer , rsyncOnly = status == UsableRsyncServer
} }
probe extraopts = do probe extraopts = do
let remotecommand = shellWrap $ join ";" let remotecommand = shellWrap $ intercalate ";"
[ report "loggedin" [ report "loggedin"
, checkcommand "git-annex-shell" , checkcommand "git-annex-shell"
, checkcommand "rsync" , checkcommand "rsync"
@ -287,7 +287,7 @@ makeSsh' rsync setup sshdata keypair =
where where
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
remotedir = T.unpack $ sshDirectory sshdata remotedir = T.unpack $ sshDirectory sshdata
remoteCommand = shellWrap $ join "&&" $ catMaybes remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
[ Just $ "mkdir -p " ++ shellEscape remotedir [ Just $ "mkdir -p " ++ shellEscape remotedir
, Just $ "cd " ++ shellEscape remotedir , Just $ "cd " ++ shellEscape remotedir
, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi" , if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
@ -353,7 +353,7 @@ makeRsyncNet sshinput reponame setup = do
- one recommended by rsync.net documentation. I touch the file first - one recommended by rsync.net documentation. I touch the file first
- to not need to use a different method to create it. - to not need to use a different method to create it.
-} -}
let remotecommand = join ";" let remotecommand = intercalate ";"
[ "mkdir -p .ssh" [ "mkdir -p .ssh"
, "touch .ssh/authorized_keys" , "touch .ssh/authorized_keys"
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc" , "dd of=.ssh/authorized_keys oflag=append conv=notrunc"

View file

@ -97,7 +97,7 @@ xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
env <- liftIO getEnvironment env <- liftIO getEnvironment
path <- liftIO getSearchPath path <- liftIO getSearchPath
let myenv = M.fromList let myenv = M.fromList
[ ("PATH", join [searchPathSeparator] $ tmpdir:path) [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
, (relayIn, show inf) , (relayIn, show inf)
, (relayOut, show outf) , (relayOut, show outf)
, (relayControl, show controlf) , (relayControl, show controlf)

View file

@ -121,7 +121,7 @@ keyValueE size source = keyValue size source >>= maybe (return Nothing) addE
selectExtension :: FilePath -> String selectExtension :: FilePath -> String
selectExtension f selectExtension f
| null es = "" | null es = ""
| otherwise = join "." ("":es) | otherwise = intercalate "." ("":es)
where where
es = filter (not . null) $ reverse $ es = filter (not . null) $ reverse $
take 2 $ takeWhile shortenough $ take 2 $ takeWhile shortenough $

View file

@ -156,7 +156,7 @@ url2file url pathdepth = case pathdepth of
| otherwise -> error "bad --pathdepth" | otherwise -> error "bad --pathdepth"
where where
fullurl = uriRegName auth ++ uriPath url ++ uriQuery url fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
frombits a = join "/" $ a urlbits frombits a = intercalate "/" $ a urlbits
urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
filesize = take 255 filesize = take 255

View file

@ -31,7 +31,7 @@ start [] = do
error $ "Specify a name for the remote. " ++ error $ "Specify a name for the remote. " ++
if null names if null names
then "" then ""
else "Either a new name, or one of these existing special remotes: " ++ join " " names else "Either a new name, or one of these existing special remotes: " ++ intercalate " " names
start (name:ws) = do start (name:ws) = do
(u, c) <- findByName name (u, c) <- findByName name
let fullconfig = config `M.union` c let fullconfig = config `M.union` c

View file

@ -95,7 +95,7 @@ runRequests readh writeh a = do
sendRequest :: Transfer -> AssociatedFile -> Handle -> IO () sendRequest :: Transfer -> AssociatedFile -> Handle -> IO ()
sendRequest t f h = do sendRequest t f h = do
hPutStr h $ join fieldSep hPutStr h $ intercalate fieldSep
[ serialize (transferDirection t) [ serialize (transferDirection t)
, serialize (transferUUID t) , serialize (transferUUID t)
, serialize (transferKey t) , serialize (transferKey t)

View file

@ -27,12 +27,10 @@ start = do
showPackageVersion showPackageVersion
putStrLn $ "local repository version: " ++ fromMaybe "unknown" v putStrLn $ "local repository version: " ++ fromMaybe "unknown" v
putStrLn $ "default repository version: " ++ defaultVersion putStrLn $ "default repository version: " ++ defaultVersion
putStrLn $ "supported repository versions: " ++ vs supportedVersions putStrLn $ "supported repository versions: " ++ unwords supportedVersions
putStrLn $ "upgrade supported from repository versions: " ++ vs upgradableVersions putStrLn $ "upgrade supported from repository versions: " ++ unwords upgradableVersions
putStrLn $ "build flags: " ++ unwords buildFlags putStrLn $ "build flags: " ++ unwords buildFlags
stop stop
where
vs = join " "
showPackageVersion :: IO () showPackageVersion :: IO ()
showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion

View file

@ -2,7 +2,7 @@
module Common (module X) where module Common (module X) where
import Control.Monad as X hiding (join) import Control.Monad as X
import Control.Monad.IfElse as X import Control.Monad.IfElse as X
import Control.Applicative as X import Control.Applicative as X
import "mtl" Control.Monad.State.Strict as X (liftIO) import "mtl" Control.Monad.State.Strict as X (liftIO)
@ -10,7 +10,7 @@ import Control.Exception.Extensible as X (IOException)
import Data.Maybe as X import Data.Maybe as X
import Data.List as X hiding (head, tail, init, last) import Data.List as X hiding (head, tail, init, last)
import Data.String.Utils as X import Data.String.Utils as X hiding (join)
import "MissingH" System.Path as X import "MissingH" System.Path as X
import System.FilePath as X import System.FilePath as X

View file

@ -130,7 +130,8 @@ remoteNamed n constructor = do
remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey k = remoteNamed basename remoteNamedFromKey k = remoteNamed basename
where where
basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k basename = intercalate "." $
reverse $ drop 1 $ reverse $ drop 1 $ split "." k
{- Constructs a new Repo for one of a Repo's remotes using a given {- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -} - location (ie, an url). -}

View file

@ -20,7 +20,6 @@ module Git.Queue (
import qualified Data.Map as M import qualified Data.Map as M
import System.IO import System.IO
import System.Process import System.Process
import Data.String.Utils
import Utility.SafeCommand import Utility.SafeCommand
import Common import Common
@ -151,7 +150,7 @@ runAction repo (UpdateIndexAction streamers) =
runAction repo action@(CommandAction {}) = runAction repo action@(CommandAction {}) =
withHandle StdinHandle createProcessSuccess p $ \h -> do withHandle StdinHandle createProcessSuccess p $ \h -> do
fileEncoding h fileEncoding h
hPutStr h $ join "\0" $ getFiles action hPutStr h $ intercalate "\0" $ getFiles action
hClose h hClose h
where where
p = (proc "xargs" params) { env = gitEnv repo } p = (proc "xargs" params) { env = gitEnv repo }

View file

@ -179,7 +179,7 @@ fileNotFound file = do
[ "git-annex:", file, "not found" ] [ "git-annex:", file, "not found" ]
indent :: String -> String indent :: String -> String
indent = join "\n" . map (\l -> " " ++ l) . lines indent = intercalate "\n" . map (\l -> " " ++ l) . lines
{- Shows a JSON fragment only when in json mode. -} {- Shows a JSON fragment only when in json mode. -}
maybeShowJSON :: JSON a => [(String, a)] -> Annex () maybeShowJSON :: JSON a => [(String, a)] -> Annex ()

View file

@ -238,7 +238,7 @@ showTriedRemotes :: [Remote] -> Annex ()
showTriedRemotes [] = noop showTriedRemotes [] = noop
showTriedRemotes remotes = showTriedRemotes remotes =
showLongNote $ "Unable to access these remotes: " ++ showLongNote $ "Unable to access these remotes: " ++
join ", " (map name remotes) intercalate ", " (map name remotes)
forceTrust :: TrustLevel -> String -> Annex () forceTrust :: TrustLevel -> String -> Annex ()
forceTrust level remotename = do forceTrust level remotename = do

View file

@ -257,7 +257,7 @@ bup2GitRemote r
where where
bits = split ":" r bits = split ":" r
host = Prelude.head bits host = Prelude.head bits
dir = join ":" $ drop 1 bits dir = intercalate ":" $ drop 1 bits
-- "host:~user/dir" is not supported specially by bup; -- "host:~user/dir" is not supported specially by bup;
-- "host:dir" is relative to the home directory; -- "host:dir" is relative to the home directory;
-- "host:" goes in ~/.bup -- "host:" goes in ~/.bup

View file

@ -123,7 +123,7 @@ storeCipher c (SharedCipher t) = M.insert "cipher" (toB64 t) c
storeCipher c (EncryptedCipher t ks) = storeCipher c (EncryptedCipher t ks) =
M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c
where where
showkeys (KeyIds l) = join "," l showkeys (KeyIds l) = intercalate "," l
{- Extracts an StorableCipher from a remote's configuration. -} {- Extracts an StorableCipher from a remote's configuration. -}
extractCipher :: RemoteConfig -> Maybe StorableCipher extractCipher :: RemoteConfig -> Maybe StorableCipher

View file

@ -143,7 +143,7 @@ oldlog2key l
-- as the v2 key that it is. -- as the v2 key that it is.
readKey1 :: String -> Key readKey1 :: String -> Key
readKey1 v readKey1 v
| mixup = fromJust $ file2key $ join ":" $ Prelude.tail bits | mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits
| otherwise = Key | otherwise = Key
{ keyName = n { keyName = n
, keyBackendName = b , keyBackendName = b
@ -153,7 +153,7 @@ readKey1 v
where where
bits = split ":" v bits = split ":" v
b = Prelude.head bits b = Prelude.head bits
n = join ":" $ drop (if wormy then 3 else 1) bits n = intercalate ":" $ drop (if wormy then 3 else 1) bits
t = if wormy t = if wormy
then Just (Prelude.read (bits !! 1) :: EpochTime) then Just (Prelude.read (bits !! 1) :: EpochTime)
else Nothing else Nothing
@ -165,7 +165,7 @@ readKey1 v
showKey1 :: Key -> String showKey1 :: Key -> String
showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } = showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } =
join ":" $ filter (not . null) [b, showifhere t, showifhere s, n] intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n]
where where
showifhere Nothing = "" showifhere Nothing = ""
showifhere (Just v) = show v showifhere (Just v) = show v

View file

@ -32,7 +32,7 @@ setupLsof = do
when (isAbsolute cmd) $ do when (isAbsolute cmd) $ do
path <- getSearchPath path <- getSearchPath
let path' = takeDirectory cmd : path let path' = takeDirectory cmd : path
setEnv "PATH" (join [searchPathSeparator] path') True setEnv "PATH" (intercalate [searchPathSeparator] path') True
{- Checks each of the files in a directory to find open files. {- Checks each of the files in a directory to find open files.
- Note that this will find hard links to files elsewhere that are open. -} - Note that this will find hard links to files elsewhere that are open. -}

View file

@ -22,7 +22,7 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman
{- rsync requires some weird, non-shell like quoting in {- rsync requires some weird, non-shell like quoting in
- here. A doubled single quote inside the single quoted - here. A doubled single quote inside the single quoted
- string is a single quote. -} - string is a single quote. -}
escape s = "'" ++ join "''" (split "'" s) ++ "'" escape s = "'" ++ intercalate "''" (split "'" s) ++ "'"
{- Runs rsync in server mode to send a file. -} {- Runs rsync in server mode to send a file. -}
rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool