From 3f41c6bb637c79f2d0343bbfe0c1ad5bd100a293 Mon Sep 17 00:00:00 2001
From: Mikhail Glushenkov <mikhail.glushenkov@gmail.com>
Date: Thu, 12 May 2016 02:30:39 +0200
Subject: [PATCH] Use a custom ADT instead of a Bool.
---
cabal-install/Distribution/Client/Setup.hs | 12 ++++--
cabal-install/Distribution/Client/Upload.hs | 46 +++++++++++----------
2 files changed, 33 insertions(+), 25 deletions(-)
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index b7a83b6342..d965c089ca 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -35,7 +35,7 @@ module Distribution.Client.Setup
, getCommand, unpackCommand, GetFlags(..)
, checkCommand
, formatCommand
- , uploadCommand, UploadFlags(..)
+ , uploadCommand, UploadFlags(..), IsCandidate(..)
, reportCommand, ReportFlags(..)
, runCommand
, initCommand, IT.InitFlags(..)
@@ -1426,8 +1426,12 @@ instance Semigroup InstallFlags where
-- * Upload flags
-- ------------------------------------------------------------
+-- | Is this a candidate package or a package to be published?
+data IsCandidate = IsCandidate | IsPublished
+ deriving Eq
+
data UploadFlags = UploadFlags {
- uploadCandidate :: Flag Bool,
+ uploadCandidate :: Flag IsCandidate,
uploadDoc :: Flag Bool,
uploadUsername :: Flag Username,
uploadPassword :: Flag Password,
@@ -1437,7 +1441,7 @@ data UploadFlags = UploadFlags {
defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags {
- uploadCandidate = toFlag True,
+ uploadCandidate = toFlag IsCandidate,
uploadDoc = toFlag False,
uploadUsername = mempty,
uploadPassword = mempty,
@@ -1463,7 +1467,7 @@ uploadCommand = CommandUI {
,option [] ["publish"]
"Publish the package instead of uploading it as a candidate."
uploadCandidate (\v flags -> flags { uploadCandidate = v })
- falseArg
+ (noArg (Flag IsPublished))
,option ['d'] ["documentation"]
("Upload documentation instead of a source package. "
diff --git a/cabal-install/Distribution/Client/Upload.hs b/cabal-install/Distribution/Client/Upload.hs
index 0053b928b2..320b0d4fb4 100644
--- a/cabal-install/Distribution/Client/Upload.hs
+++ b/cabal-install/Distribution/Client/Upload.hs
@@ -5,7 +5,7 @@ import Distribution.Client.Types ( Username(..), Password(..)
import Distribution.Client.HttpUtils
( HttpTransport(..), remoteRepoTryUpgradeToHttps )
import Distribution.Client.Setup
- ( RepoContext(..) )
+ ( IsCandidate(..), RepoContext(..) )
import Distribution.Simple.Utils (notice, warn, info, die)
import Distribution.Verbosity (Verbosity)
@@ -42,9 +42,9 @@ stripExtensions exts path = foldM f path (reverse exts)
| otherwise = Nothing
upload :: Verbosity -> RepoContext
- -> Maybe Username -> Maybe Password -> Bool -> [FilePath]
+ -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]
-> IO ()
-upload verbosity repoCtxt mUsername mPassword candidate paths = do
+upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
let repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt
targetRepo <-
@@ -55,15 +55,17 @@ upload verbosity repoCtxt mUsername mPassword candidate paths = do
rootIfEmpty x = if null x then "/" else x
uploadURI = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>
- if candidate
- then "packages/candidates"
- else "upload"
+ case isCandidate of
+ IsCandidate -> "packages/candidates"
+ IsPublished -> "upload"
}
packageURI pkgid = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI)
FilePath.Posix.</> concat
[ "package/", pkgid
- , if candidate then "/candidate" else ""
+ , case isCandidate of
+ IsCandidate -> "/candidate"
+ IsPublished -> ""
]
}
Username username <- maybe promptUsername return mUsername
@@ -73,15 +75,15 @@ upload verbosity repoCtxt mUsername mPassword candidate paths = do
notice verbosity $ "Uploading " ++ path ++ "... "
case fmap takeFileName (stripExtensions ["tar", "gz"] path) of
Just pkgid -> handlePackage transport verbosity uploadURI
- (packageURI pkgid) auth candidate path
+ (packageURI pkgid) auth isCandidate path
-- This case shouldn't really happen, since we check in Main that we
-- only pass tar.gz files to upload.
Nothing -> die $ "Not a tar.gz file: " ++ path
uploadDoc :: Verbosity -> RepoContext
- -> Maybe Username -> Maybe Password -> Bool -> FilePath
+ -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath
-> IO ()
-uploadDoc verbosity repoCtxt mUsername mPassword candidate path = do
+uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do
let repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt
targetRepo <-
@@ -94,7 +96,9 @@ uploadDoc verbosity repoCtxt mUsername mPassword candidate path = do
uriPath = rootIfEmpty (uriPath targetRepoURI)
FilePath.Posix.</> concat
[ "package/", pkgid
- , if candidate then "/candidate" else ""
+ , case isCandidate of
+ IsCandidate -> "/candidate"
+ IsPublished -> ""
, "/docs"
]
}
@@ -171,12 +175,12 @@ report verbosity repoCtxt mUsername mPassword = do
return ()
handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth
- -> Bool -> FilePath -> IO ()
-handlePackage transport verbosity uri packageUri auth candidate path =
+ -> IsCandidate -> FilePath -> IO ()
+handlePackage transport verbosity uri packageUri auth isCandidate path =
do resp <- postHttpFile transport verbosity uri path auth
case resp of
(code,warnings) | code `elem` [200, 204] ->
- notice verbosity $ okMessage ++
+ notice verbosity $ okMessage isCandidate ++
if null warnings then "" else "\n" ++ formatWarnings (trim warnings)
(code,err) -> do
notice verbosity $ "Error uploading " ++ path ++ ": "
@@ -184,13 +188,13 @@ handlePackage transport verbosity uri packageUri auth candidate path =
++ err
exitFailure
where
- okMessage
- | candidate =
- "Package successfully uploaded as candidate. "
- ++ "You can now preview the result at '" ++ show packageUri
- ++ "'. To publish the candidate, use 'cabal upload --publish'."
- | otherwise = "Package successfully published. You can now view it at '"
- ++ show packageUri ++ "'."
+ okMessage IsCandidate =
+ "Package successfully uploaded as candidate. "
+ ++ "You can now preview the result at '" ++ show packageUri
+ ++ "'. To publish the candidate, use 'cabal upload --publish'."
+ okMessage IsPublished =
+ "Package successfully published. You can now view it at '"
+ ++ show packageUri ++ "'."
formatWarnings :: String -> String
formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x
--
GitLab