simplified a bunch of Maybe handling

This commit is contained in:
Joey Hess 2011-05-15 02:49:43 -04:00
parent efa7f54405
commit cad0e1c8b7
19 changed files with 81 additions and 140 deletions

View file

@ -76,10 +76,9 @@ list = do
{- Looks up a backend in a list. May fail if unknown. -}
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
lookupBackendName bs s =
case maybeLookupBackendName bs s of
Just b -> b
Nothing -> error $ "unknown backend " ++ s
lookupBackendName bs s = maybe unknown id $ maybeLookupBackendName bs s
where
unknown = error $ "unknown backend " ++ s
maybeLookupBackendName :: [Backend Annex] -> String -> Maybe (Backend Annex)
maybeLookupBackendName bs s =
if 1 /= length matches
@ -91,23 +90,18 @@ maybeLookupBackendName bs s =
storeFileKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
storeFileKey file trybackend = do
bs <- list
let bs' = case trybackend of
Nothing -> bs
Just backend -> backend:bs
let bs' = maybe bs (:bs) trybackend
storeFileKey' bs' file
storeFileKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
storeFileKey' [] _ = return Nothing
storeFileKey' (b:bs) file = do
result <- (B.getKey b) file
case result of
Nothing -> nextbackend
Just key -> do
storeFileKey' (b:bs) file = maybe nextbackend store =<< (B.getKey b) file
where
nextbackend = storeFileKey' bs file
store key = do
stored <- (B.storeFileKey b) file key
if (not stored)
then nextbackend
else return $ Just (key, b)
where
nextbackend = storeFileKey' bs file
{- Attempts to retrieve an key from one of the backends, saving it to
- a specified location. -}
@ -148,11 +142,8 @@ lookupFile file = do
getsymlink = do
l <- readSymbolicLink file
return $ takeFileName l
makekey bs l =
case fileKey l of
Just k -> makeret k l bs
Nothing -> return Nothing
makeret k l bs =
makekey bs l = maybe (return Nothing) (makeret bs l) (fileKey l)
makeret bs l k =
case maybeLookupBackendName bs bname of
Just backend -> return $ Just (k, backend)
Nothing -> do

View file

@ -14,7 +14,5 @@ toB64 :: String -> String
toB64 = encode . s2w8
fromB64 :: String -> String
fromB64 s =
case decode s of
Nothing -> error "bad base64 encoded data"
Just ws -> w82s ws
fromB64 s = maybe bad w82s $ decode s
where bad = error "bad base64 encoded data"

View file

@ -14,6 +14,7 @@ import Control.Monad (filterM, liftM, when)
import System.Path.WildMatch
import Text.Regex.PCRE.Light.Char8
import Data.List
import Data.Maybe
import Types
import qualified Backend
@ -106,18 +107,10 @@ doCommand start = do
return c
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
notAnnexed file a = do
r <- Backend.lookupFile file
case r of
Just _ -> return Nothing
Nothing -> a
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
isAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex (Maybe a)) -> Annex (Maybe a)
isAnnexed file a = do
r <- Backend.lookupFile file
case r of
Just v -> a v
Nothing -> return Nothing
isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file
notBareRepo :: Annex a -> Annex a
notBareRepo a = do
@ -183,9 +176,7 @@ withFilesUnlocked' typechanged a params = do
withKeys :: CommandSeekKeys
withKeys a params = return $ map a $ map parse params
where
parse p = case readKey p of
Just k -> k
Nothing -> error "bad key"
parse p = maybe (error "bad key") id $ readKey p
withTempFile :: CommandSeekStrings
withTempFile a params = return $ map a params
withNothing :: CommandSeekNothing
@ -206,9 +197,7 @@ filterFiles l = do
else return $ filter (notExcluded $ wildsRegex exclude) l'
where
notState f = not $ stateDir `isPrefixOf` f
notExcluded r f = case match r f [] of
Nothing -> True
Just _ -> False
notExcluded r f = isJust $ match r f []
wildsRegex :: [String] -> Regex
wildsRegex ws = compile regex []
@ -257,11 +246,10 @@ cmdlineKey = do
case k of
Nothing -> nokey
Just "" -> nokey
Just kstring -> case readKey kstring of
Nothing -> error "bad key"
Just key -> return key
Just kstring -> maybe badkey return $ readKey kstring
where
nokey = error "please specify the key with --key"
badkey = error "bad key"
{- Given an original list of files, and an expanded list derived from it,
- ensures that the original list's ordering is preserved.

View file

@ -58,14 +58,13 @@ start (unused, unusedbad, unusedtmp) s = notBareRepo $ search
next $ a key
perform :: Key -> CommandPerform
perform key = do
from <- Annex.getState Annex.fromremote
case from of
Just name -> do
perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote
where
dropremote name = do
r <- Remote.byName name
showNote $ "from " ++ Remote.name r ++ "..."
next $ Command.Move.fromCleanup r True key
_ -> do
droplocal = do
backend <- keyBackend key
Command.Drop.perform key backend (Just 0) -- force drop

View file

@ -68,11 +68,11 @@ cleanup u c = do
findByName :: String -> Annex (UUID, RemoteClass.RemoteConfig)
findByName name = do
m <- Remote.readRemoteLog
case findByName' name m of
Just i -> return i
Nothing -> do
maybe generate return $ findByName' name m
where
generate = do
uuid <- liftIO $ genUUID
return $ (uuid, M.insert nameKey name M.empty)
return (uuid, M.insert nameKey name M.empty)
findByName' :: String -> M.Map UUID RemoteClass.RemoteConfig -> Maybe (UUID, RemoteClass.RemoteConfig)
findByName' n m = if null matches then Nothing else Just $ head matches
@ -86,12 +86,13 @@ findByName' n m = if null matches then Nothing else Just $ head matches
{- find the specified remote type -}
findType :: RemoteClass.RemoteConfig -> Annex (RemoteClass.RemoteType Annex)
findType config =
case M.lookup typeKey config of
Nothing -> error "Specify the type of remote with type="
Just s -> case filter (\i -> RemoteClass.typename i == s) Remote.remoteTypes of
findType config = maybe unspecified specified $ M.lookup typeKey config
where
unspecified = error "Specify the type of remote with type="
specified s = case filter (findtype s) Remote.remoteTypes of
[] -> error $ "Unknown remote type " ++ s
(t:_) -> return t
findtype s i = RemoteClass.typename i == s
{- The name of a configured remote is stored in its config using this key. -}
nameKey :: String

View file

@ -84,10 +84,7 @@ repoName umap r
| otherwise = M.findWithDefault fallback repouuid umap
where
repouuid = getUncachedUUID r
fallback =
case (Git.repoRemoteName r) of
Just n -> n
Nothing -> "unknown"
fallback = maybe "unknown" id $ Git.repoRemoteName r
{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
@ -121,13 +118,10 @@ edge umap fullinfo from to =
{- Only name an edge if the name is different than the name
- that will be used for the destination node, and is
- different from its hostname. (This reduces visual clutter.) -}
edgename =
case (Git.repoRemoteName to) of
Nothing -> Nothing
Just n ->
if (n == repoName umap fullto || n == hostname fullto)
then Nothing
else Just n
edgename = maybe Nothing calcname $ Git.repoRemoteName to
calcname n
| n == repoName umap fullto || n == hostname fullto = Nothing
| otherwise = Just n
unreachable :: String -> String
unreachable = Dot.fillColor "red"

View file

@ -41,12 +41,7 @@ start = notBareRepo $ do
perform :: CommandPerform
perform = do
from <- Annex.getState Annex.fromremote
case from of
Just name -> do
r <- Remote.byName name
checkRemoteUnused r
_ -> checkUnused
maybe checkUnused checkRemoteUnused =<< Annex.getState Annex.fromremote
next $ return True
checkUnused :: Annex ()
@ -63,8 +58,11 @@ checkUnused = do
writeUnusedFile file unusedlist
return $ length l
checkRemoteUnused :: Remote.Remote Annex -> Annex ()
checkRemoteUnused r = do
checkRemoteUnused :: String -> Annex ()
checkRemoteUnused name = checkRemoteUnused' =<< Remote.byName name
checkRemoteUnused' :: Remote.Remote Annex -> Annex ()
checkRemoteUnused' r = do
g <- Annex.gitRepo
showNote $ "checking for unused data on " ++ Remote.name r ++ "..."
referenced <- getKeysReferenced

View file

@ -57,11 +57,11 @@ calcGitLink :: FilePath -> Key -> Annex FilePath
calcGitLink file key = do
g <- Annex.gitRepo
cwd <- liftIO $ getCurrentDirectory
let absfile = case absNormPath cwd file of
Just f -> f
Nothing -> error $ "unable to normalize " ++ file
let absfile = maybe whoops id $ absNormPath cwd file
return $ relPathDirToFile (parentDir absfile)
(Git.workTree g) </> ".git" </> annexLocation key
where
whoops = error $ "unable to normalize " ++ file
{- Updates the LocationLog when a key's presence changes in the current
- repository.
@ -148,9 +148,7 @@ checkDiskSpace' :: Integer -> Key -> Annex ()
checkDiskSpace' adjustment key = do
g <- Annex.gitRepo
r <- getConfig g "diskreserve" ""
let reserve = case readSize dataUnits r of
Nothing -> megabyte
Just v -> v
let reserve = maybe megabyte id $ readSize dataUnits r
stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
case (stats, keySize key) of
(Nothing, _) -> return ()

View file

@ -238,10 +238,8 @@ configKeyIds c = do
keyIdField s = (split ":" s) !! 4
configGet :: RemoteConfig -> String -> String
configGet c key =
case M.lookup key c of
Just v -> v
Nothing -> error $ "missing " ++ key ++ " in remote config"
configGet c key = maybe missing id $ M.lookup key c
where missing = error $ "missing " ++ key ++ " in remote config"
hmacWithCipher :: Cipher -> String -> String
hmacWithCipher c = hmacWithCipher' (cipherHmac c)

5
Dot.hs
View file

@ -20,10 +20,7 @@ graphNode nodeid desc = label desc $ quote nodeid
{- an edge between two nodes -}
graphEdge :: String -> String -> Maybe String -> String
graphEdge fromid toid desc = indent $
case desc of
Nothing -> edge
Just d -> label d edge
graphEdge fromid toid desc = indent $ maybe edge (\d -> label d edge) desc
where
edge = quote fromid ++ " -> " ++ quote toid

View file

@ -122,9 +122,8 @@ repoFromUrl url
| startswith "file://" url = repoFromAbsPath $ uriPath u
| otherwise = return $ newFrom $ Url u
where
u = case (parseURI url) of
Just v -> v
Nothing -> error $ "bad url " ++ url
u = maybe bad id $ parseURI url
bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -}
repoFromUnknown :: Repo
@ -264,9 +263,7 @@ workTreeFile repo@(Repo { location = Dir d }) file = do
absrepo = case (absNormPath "/" d) of
Just f -> addTrailingPathSeparator f
Nothing -> error $ "bad repo" ++ repoDescribe repo
absfile c = case (secureAbsNormPath c file) of
Just f -> f
Nothing -> file
absfile c = maybe file id $ secureAbsNormPath c file
inrepo f = absrepo `isPrefixOf` f
workTreeFile repo _ = assertLocal repo $ error "internal"
@ -352,9 +349,7 @@ reap :: IO ()
reap = do
-- throws an exception when there are no child processes
r <- catch (getAnyProcessStatus False True) (\_ -> return Nothing)
case r of
Nothing -> return ()
Just _ -> reap
maybe (return ()) (const reap) r
{- Scans for files that are checked into git at the specified locations. -}
inRepo :: Repo -> [FilePath] -> IO [FilePath]

View file

@ -71,9 +71,7 @@ instance Read LogLine where
-- Such lines have a status of Undefined.
readsPrec _ string =
if length w == 3
then case pdate of
Just v -> good v
Nothing -> bad
then maybe bad good pdate
else bad
where
w = words string

View file

@ -68,9 +68,8 @@ gen r u c = do
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
bupSetup u c = do
-- verify configuration is sane
let buprepo = case M.lookup "buprepo" c of
Nothing -> error "Specify buprepo="
Just r -> r
let buprepo = maybe (error "Specify buprepo=") id $
M.lookup "buprepo" c
c' <- encryptionSetup c
-- bup init will create the repository.

View file

@ -60,9 +60,8 @@ gen r u c = do
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
directorySetup u c = do
-- verify configuration is sane
let dir = case M.lookup "directory" c of
Nothing -> error "Specify directory="
Just d -> d
let dir = maybe (error "Specify directory=") id $
M.lookup "directory" c
e <- liftIO $ doesDirectoryExist dir
when (not e) $ error $ "Directory does not exist: " ++ dir
c' <- encryptionSetup c

View file

@ -73,11 +73,10 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
{- Gets encryption Cipher. The decrypted Cipher is cached in the Annex
- state. -}
remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
remoteCipher c = do
cache <- Annex.getState Annex.cipher
case cache of
Just cipher -> return $ Just cipher
Nothing -> case extractCipher c of
remoteCipher c = maybe expensive cached =<< Annex.getState Annex.cipher
where
cached cipher = return $ Just cipher
expensive = case extractCipher c of
Nothing -> return Nothing
Just encipher -> do
showNote "gpg"

View file

@ -61,9 +61,8 @@ gen r u c = do
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
hookSetup u c = do
let hooktype = case M.lookup "hooktype" c of
Nothing -> error "Specify hooktype="
Just r -> r
let hooktype = maybe (error "Specify hooktype=") id $
M.lookup "hooktype" c
c' <- encryptionSetup c
gitConfigSpecialRemote u c' "hooktype" hooktype
return c'
@ -94,14 +93,12 @@ lookupHook hooktype hook =do
hookname = hooktype ++ "-" ++ hook ++ "-hook"
runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
runHook hooktype hook k f a = do
command <- lookupHook hooktype hook
case command of
Nothing -> return False
Just c -> do
runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype hook
where
run command = do
showProgress -- make way for hook output
res <- liftIO $ boolSystemEnv
"sh" [Param "-c", Param c] $ hookEnv k f
"sh" [Param "-c", Param command] $ hookEnv k f
if res
then a
else do

View file

@ -82,9 +82,8 @@ genRsyncOpts r = do
rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
rsyncSetup u c = do
-- verify configuration is sane
let url = case M.lookup "rsyncurl" c of
Nothing -> error "Specify rsyncurl="
Just d -> d
let url = maybe (error "Specify rsyncurl=") id $
M.lookup "rsyncurl" c
c' <- encryptionSetup c
-- The rsyncurl is stored in git config, not only in this remote's

View file

@ -123,11 +123,7 @@ storeHelper (conn, bucket) r k file = do
content <- liftIO $ L.readFile file
-- size is provided to S3 so the whole content does not need to be
-- buffered to calculate it
size <- case keySize k of
Just s -> return $ fromIntegral s
Nothing -> do
s <- liftIO $ getFileStatus file
return $ fileSize s
size <- maybe getsize (return . fromIntegral) $ keySize k
let object = setStorageClass storageclass $
S3Object bucket (show k) ""
[("Content-Length",(show size))] content
@ -137,6 +133,9 @@ storeHelper (conn, bucket) r k file = do
case fromJust $ M.lookup "storageclass" $ fromJust $ config r of
"REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY
_ -> STANDARD
getsize = do
s <- liftIO $ getFileStatus file
return $ fileSize s
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
retrieve r k f = s3Action r False $ \(conn, bucket) -> do
@ -201,11 +200,8 @@ bucketKey :: String -> Key -> S3Object
bucketKey bucket k = S3Object bucket (show k) "" [] L.empty
s3ConnectionRequired :: RemoteConfig -> Annex AWSConnection
s3ConnectionRequired c = do
conn <- s3Connection c
case conn of
Nothing -> error "Cannot connect to S3"
Just conn' -> return conn'
s3ConnectionRequired c =
maybe (error "Cannot connect to S3") return =<< s3Connection c
s3Connection :: RemoteConfig -> Annex (Maybe AWSConnection)
s3Connection c = do

View file

@ -165,9 +165,7 @@ prop_parentDir_basics dir
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
where
norm p = case (absNormPath p ".") of
Just r -> r
Nothing -> ""
norm p = maybe "" id $ absNormPath p "."
a' = norm a
b' = norm b
@ -180,10 +178,9 @@ absPath file = do
{- Converts a filename into a normalized, absolute path
- from the specified cwd. -}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom cwd file =
case absNormPath cwd file of
Just f -> f
Nothing -> error $ "unable to normalize " ++ file
absPathFrom cwd file = maybe bad id $ absNormPath cwd file
where
bad = error $ "unable to normalize " ++ file
{- Constructs a relative path from the CWD to a file.
-