Commit 2d0080cb authored by Oleg Grenrus's avatar Oleg Grenrus

Add RepoName newtype

Make it, LocalRepo, RemoteRepo, IndexState and Timestamp use
Pretty/Parsec instead of Text

Mostly adding `unRepoName` to error printing statements
parent 2e032319
......@@ -24,7 +24,7 @@ import Distribution.Client.ProjectConfig
, projectConfigWithSolverRepoContext
, withProjectOrGlobalConfig )
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), isRepoRemote )
( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), isRepoRemote )
import Distribution.Client.HttpUtils
( DownloadResult(..) )
import Distribution.Client.FetchUtils
......@@ -45,12 +45,12 @@ import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.IndexUtils
( updateRepoIndexCache, Index(..), writeIndexTimestamp
, currentIndexTimestamp, indexBaseName )
import Distribution.Deprecated.Text
( Text(..), display, simpleParse )
import Distribution.Pretty (Pretty (..), prettyShow)
import Distribution.Parsec (Parsec (..), simpleParsec)
import Data.Maybe (fromJust)
import qualified Distribution.Deprecated.ReadP as ReadP
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
import Control.Monad (mapM, mapM_)
import qualified Data.ByteString.Lazy as BS
......@@ -100,21 +100,18 @@ updateCommand = Client.installCommand {
}
data UpdateRequest = UpdateRequest
{ _updateRequestRepoName :: String
{ _updateRequestRepoName :: RepoName
, _updateRequestRepoState :: IndexState
} deriving (Show)
instance Text UpdateRequest where
disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s
parse = parseWithState ReadP.+++ parseHEAD
where parseWithState = do
name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ','))
_ <- ReadP.char ','
state <- parse
return (UpdateRequest name state)
parseHEAD = do
name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof
return (UpdateRequest name IndexStateHead)
instance Pretty UpdateRequest where
pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
instance Parsec UpdateRequest where
parsec = do
name <- parsec
state <- P.char ',' *> parsec <|> pure IndexStateHead
return (UpdateRequest name state)
updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags )
......@@ -132,7 +129,7 @@ updateAction ( configFlags, configExFlags, installFlags
let repos = filter isRepoRemote $ repoContextRepos repoCtxt
repoName = remoteRepoName . repoRemote
parseArg :: String -> IO UpdateRequest
parseArg s = case simpleParse s of
parseArg s = case simpleParsec s of
Just r -> return r
Nothing -> die' verbosity $
"'v2-update' unable to parse repo: \"" ++ s ++ "\""
......@@ -144,9 +141,9 @@ updateAction ( configFlags, configExFlags, installFlags
, not (r `elem` remoteRepoNames)]
unless (null unknownRepos) $
die' verbosity $ "'v2-update' repo(s): \""
++ intercalate "\", \"" unknownRepos
++ intercalate "\", \"" (map unRepoName unknownRepos)
++ "\" can not be found in known remote repo(s): "
++ intercalate ", " remoteRepoNames
++ intercalate ", " (map unRepoName remoteRepoNames)
let reposToUpdate :: [(Repo, IndexState)]
reposToUpdate = case updateRepoRequests of
......@@ -162,10 +159,10 @@ updateAction ( configFlags, configExFlags, installFlags
[] -> return ()
[(remoteRepo, _)] ->
notice verbosity $ "Downloading the latest package list from "
++ repoName remoteRepo
++ unRepoName (repoName remoteRepo)
_ -> notice verbosity . unlines
$ "Downloading the latest package lists from: "
: map (("- " ++) . repoName . fst) reposToUpdate
: map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
jobCtrl <- newParallelJobControl (length reposToUpdate)
mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
......@@ -224,5 +221,4 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
when (current_ts /= nullTimestamp) $
noticeNoWrap verbosity $
"To revert to previous state run:\n" ++
" cabal v2-update '" ++ remoteRepoName (repoRemote repo)
++ "," ++ display current_ts ++ "'\n"
" cabal v2-update '" ++ prettyShow (UpdateRequest (remoteRepoName (repoRemote repo)) (IndexStateTime current_ts)) ++ "'\n"
......@@ -53,6 +53,7 @@ import Distribution.Deprecated.ViewAsFieldDescr
import Distribution.Client.Types
( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo
, AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps
, RepoName (..), unRepoName
)
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
......@@ -64,8 +65,7 @@ import Distribution.Client.Setup
, initOptions
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, showRemoteRepo, parseRemoteRepo, readRemoteRepo )
, ReportFlags(..), reportCommand )
import Distribution.Client.CmdInstall.ClientInstallFlags
( ClientInstallFlags(..), defaultClientInstallFlags
, clientInstallOptions )
......@@ -128,6 +128,8 @@ import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Compat.Semigroup
import qualified Text.PrettyPrint as Disp
( render, text, empty )
import Distribution.Parsec (parsec, simpleParsec)
import Distribution.Pretty (pretty)
import Text.PrettyPrint
( ($+$) )
import Text.PrettyPrint.HughesPJ
......@@ -645,8 +647,9 @@ defaultUserInstall = True
defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
where
name = "hackage.haskell.org"
uri = URI "http:" (Just (URIAuth "" name "")) "/" "" ""
str = "hackage.haskell.org"
name = RepoName str
uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
-- Note that lots of old ~/.cabal/config files will have the old url
-- http://hackage.haskell.org/packages/archive
-- but new config files can use the new url (without the /packages/archive)
......@@ -1037,7 +1040,7 @@ deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
deprecatedFieldDescriptions =
[ liftGlobalFlag $
listField "repos"
(Disp.text . showRemoteRepo) parseRemoteRepo
pretty parsec
(fromNubList . globalRemoteRepos)
(\rs cfg -> cfg { globalRemoteRepos = toNubList rs })
, liftGlobalFlag $
......@@ -1196,7 +1199,9 @@ parseConfig src initial = \str -> do
parseSections (rs, ls, h, i, u, g, p, a)
(ParseUtils.Section lineno "repository" name fs) = do
r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs
name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $
simpleParsec name
r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
r'' <- postProcessRepo lineno name r'
case r'' of
Left local -> return (rs, local:ls, h, i, u, g, p, a)
......@@ -1204,7 +1209,7 @@ parseConfig src initial = \str -> do
parseSections (rs, ls, h, i, u, g, p, a)
(ParseUtils.F lno "remote-repo" raw) = do
let mr' = readRemoteRepo raw
let mr' = simpleParsec raw
r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
return (r':rs, ls, h, i, u, g, p, a)
......@@ -1253,11 +1258,14 @@ parseConfig src initial = \str -> do
return accum
postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo lineno reponame repo0 = do
when (null reponame) $
postProcessRepo lineno reponameStr repo0 = do
when (null reponameStr) $
syntaxError lineno $ "a 'repository' section requires the "
++ "repository name as an argument"
reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $
simpleParsec reponameStr
case uriScheme (remoteRepoURI repo0) of
-- TODO: check that there are no authority, query or fragment
-- Note: the trailing colon is important
......@@ -1329,7 +1337,7 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)
ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))
remoteRepoFields (Just def) vals
remoteRepoFields :: [FieldDescr RemoteRepo]
......
......@@ -17,7 +17,7 @@ import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), LocalRepo (..), localRepoCacheKey )
( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey )
import Distribution.Simple.Setup
( Flag(..), fromFlag, flagToMaybe )
import Distribution.Utils.NubList
......@@ -162,7 +162,7 @@ withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos
sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do
for_ localNoIndexRepos $ \local ->
unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
warn verbosity $ "file+noindex " ++ localRepoName local ++ " repository path is not absolute; this is fragile, and not recommended"
warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"
transportRef <- newMVar Nothing
let httpLib = Sec.HTTP.transportAdapter
......@@ -185,7 +185,7 @@ withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos
allRemoteRepos =
[ (if isSecure then RepoSecure else RepoRemote) remote cacheDir
| remote <- remoteRepos
, let cacheDir = sharedCacheDir </> remoteRepoName remote
, let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)
isSecure = remoteRepoSecure remote == Just True
]
......
......@@ -43,7 +43,7 @@ import Distribution.Simple.Utils
import Distribution.Client.Utils
( withTempFileName )
import Distribution.Client.Types
( RemoteRepo(..) )
( unRepoName, RemoteRepo(..) )
import Distribution.System
( buildOS, buildArch )
import qualified System.FilePath.Posix as FilePath.Posix
......@@ -204,8 +204,8 @@ remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps verbosity transport repo
| uriScheme (remoteRepoURI repo) == "https:"
, not (transportSupportsHttps transport)
= die' verbosity $ "The remote repository '" ++ remoteRepoName repo
++ "' specifies a URL that " ++ requiresHttpsErrorMessage
= die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)
++ "' specifies a URL that " ++ requiresHttpsErrorMessage
| otherwise = return ()
transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
......
......@@ -223,13 +223,13 @@ getSourcePackagesAtIndexState verbosity repoCtxt _
}
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
let describeState IndexStateHead = "most recent state"
describeState (IndexStateTime time) = "historical state as of " ++ display time
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
let rname = case r of
RepoRemote remote _ -> remoteRepoName remote
RepoSecure remote _ -> remoteRepoName remote
RepoLocalNoIndex local _ -> localRepoName local
RepoRemote remote _ -> unRepoName $ remoteRepoName remote
RepoSecure remote _ -> unRepoName $ remoteRepoName remote
RepoLocalNoIndex local _ -> unRepoName $ localRepoName local
RepoLocal _ -> ""
info verbosity ("Reading available packages of " ++ rname ++ "...")
......@@ -265,25 +265,24 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
case idxState' of
IndexStateHead -> do
info verbosity ("index-state("++rname++") = " ++
display (isiHeadTime isi))
info verbosity ("index-state("++rname++") = " ++ prettyShow (isiHeadTime isi))
return ()
IndexStateTime ts0 -> do
when (isiMaxTime isi /= ts0) $
if ts0 > isiMaxTime isi
then warn verbosity $
"Requested index-state " ++ display ts0
"Requested index-state " ++ prettyShow ts0
++ " is newer than '" ++ rname ++ "'!"
++ " Falling back to older state ("
++ display (isiMaxTime isi) ++ ")."
++ prettyShow (isiMaxTime isi) ++ ")."
else info verbosity $
"Requested index-state " ++ display ts0
"Requested index-state " ++ prettyShow ts0
++ " does not exist in '"++rname++"'!"
++ " Falling back to older state ("
++ display (isiMaxTime isi) ++ ")."
++ prettyShow (isiMaxTime isi) ++ ")."
info verbosity ("index-state("++rname++") = " ++
display (isiMaxTime isi) ++ " (HEAD = " ++
display (isiHeadTime isi) ++ ")")
prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
prettyShow (isiHeadTime isi) ++ ")")
pure (pis,deps)
......@@ -346,7 +345,7 @@ readRepoIndex verbosity repoCtxt repo idxState =
++ "' is missing. The repo is invalid."
RepoLocalNoIndex local _ -> warn verbosity $
"Error during construction of local+noindex "
++ localRepoName local ++ " repository index: "
++ unRepoName (localRepoName local) ++ " repository index: "
++ show e
return (mempty,mempty,emptyStateInfo)
else ioError e
......@@ -360,10 +359,10 @@ readRepoIndex verbosity repoCtxt repo idxState =
RepoLocalNoIndex {} -> return ()
errMissingPackageList repoRemote =
"The package list for '" ++ remoteRepoName repoRemote
"The package list for '" ++ unRepoName (remoteRepoName repoRemote)
++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote
errOutdatedPackageList repoRemote dt =
"The package list for '" ++ remoteRepoName repoRemote
"The package list for '" ++ unRepoName (remoteRepoName repoRemote)
++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
++ "'cabal update' to get the latest list of available packages."
......@@ -603,7 +602,7 @@ updatePackageIndexCacheFile verbosity index = do
}
writeIndexCache index cache
info verbosity ("Index cache updated to index-state "
++ display (cacheHeadTs cache))
++ prettyShow (cacheHeadTs cache))
callbackNoIndex entries = do
writeNoIndexCache verbosity index $ NoIndexCache entries
......@@ -687,14 +686,14 @@ withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo nam
Just ce -> return (Just ce)
Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file
info verbosity $ "Entries in file+noindex repository " ++ name
info verbosity $ "Entries in file+noindex repository " ++ unRepoName name
for_ entries $ \(CacheGPD gpd _) ->
info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)
callback entries
where
handler :: IOException -> IO a
handler e = die' verbosity $ "Error while updating index for " ++ name ++ " repository " ++ show e
handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e
isTarGz :: FilePath -> Maybe PackageIdentifier
isTarGz fp = do
......@@ -924,7 +923,7 @@ writeNoIndexCache verbosity index cache = do
-- | Write the 'IndexState' to the filesystem
writeIndexTimestamp :: Index -> IndexState -> IO ()
writeIndexTimestamp index st
= writeFile (timestampFile index) (display st)
= writeFile (timestampFile index) (prettyShow st)
-- | Read out the "current" index timestamp, i.e., what
-- timestamp you would use to revert to this version
......@@ -940,7 +939,7 @@ currentIndexTimestamp verbosity repoCtxt r = do
-- | Read the 'IndexState' from the filesystem
readIndexTimestamp :: Index -> IO (Maybe IndexState)
readIndexTimestamp index
= fmap simpleParse (readFile (timestampFile index))
= fmap simpleParsec (readFile (timestampFile index))
`catchIO` \e ->
if isDoesNotExistError e
then return Nothing
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
......@@ -26,15 +26,14 @@ import Distribution.Client.Compat.Prelude
-- read is needed for Text instance
import Prelude (read)
import qualified Codec.Archive.Tar.Entry as Tar
import Data.Time (UTCTime (..), fromGregorianValid,
makeTimeOfDayValid, showGregorian,
timeOfDayToTime, timeToTimeOfDay)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime,
utcTimeToPOSIXSeconds)
import qualified Distribution.Deprecated.ReadP as ReadP
import Distribution.Deprecated.Text
import qualified Text.PrettyPrint as Disp
import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Distribution.Parsec (Parsec (..))
import Distribution.Pretty (Pretty (..))
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
newtype Timestamp = TS Int64 -- Tar.EpochTime
......@@ -100,16 +99,18 @@ showTimestamp ts = case timestampToUTCTime ts of
instance Binary Timestamp
instance Structured Timestamp
instance Text Timestamp where
disp = Disp.text . showTimestamp
instance Pretty Timestamp where
pretty = Disp.text . showTimestamp
parse = parsePosix ReadP.+++ parseUTC
instance Parsec Timestamp where
parsec = parsePosix <|> parseUTC
where
-- | Parses unix timestamps, e.g. @"\@1474626019"@
parsePosix = do
_ <- ReadP.char '@'
t <- parseInteger
maybe ReadP.pfail return $ posixSecondsToTimestamp t
_ <- P.char '@'
t <- P.integral -- note, no negative timestamps
maybe (fail (show t ++ " is not representable as timestamp")) return $
posixSecondsToTimestamp t
-- | Parses ISO8601/RFC3339-style UTC timestamps,
-- e.g. @"2017-12-31T23:59:59Z"@
......@@ -120,46 +121,43 @@ instance Text Timestamp where
-- we want more control over the accepted formats.
ye <- parseYear
_ <- ReadP.char '-'
_ <- P.char '-'
mo <- parseTwoDigits
_ <- ReadP.char '-'
_ <- P.char '-'
da <- parseTwoDigits
_ <- ReadP.char 'T'
_ <- P.char 'T'
utctDay <- maybe ReadP.pfail return $
utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $
fromGregorianValid ye mo da
ho <- parseTwoDigits
_ <- ReadP.char ':'
_ <- P.char ':'
mi <- parseTwoDigits
_ <- ReadP.char ':'
_ <- P.char ':'
se <- parseTwoDigits
_ <- ReadP.char 'Z'
_ <- P.char 'Z'
utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $
utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $
makeTimeOfDayValid ho mi (realToFrac (se::Int))
maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..})
let utc = UTCTime {..}
maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc
parseTwoDigits = do
d1 <- ReadP.satisfy isDigit
d2 <- ReadP.satisfy isDigit
d1 <- P.satisfy isDigit
d2 <- P.satisfy isDigit
return (read [d1,d2])
-- A year must have at least 4 digits; e.g. "0097" is fine,
-- while "97" is not c.f. RFC3339 which
-- deprecates 2-digit years
parseYear = do
sign <- ReadP.option ' ' (ReadP.char '-')
ds <- ReadP.munch1 isDigit
when (length ds < 4) ReadP.pfail
sign <- P.option ' ' (P.char '-')
ds <- P.munch1 isDigit
when (length ds < 4) $ fail "Year should have at least 4 digits"
return (read (sign:ds))
parseInteger = do
sign <- ReadP.option ' ' (ReadP.char '-')
ds <- ReadP.munch1 isDigit
return (read (sign:ds) :: Integer)
-- | Special timestamp value to be used when 'timestamp' is
-- missing/unknown/invalid
nullTimestamp :: Timestamp
......@@ -178,14 +176,11 @@ instance Binary IndexState
instance Structured IndexState
instance NFData IndexState
instance Text IndexState where
disp IndexStateHead = Disp.text "HEAD"
disp (IndexStateTime ts) = disp ts
parse = parseHead ReadP.+++ parseTime
where
parseHead = do
_ <- ReadP.string "HEAD"
return IndexStateHead
instance Pretty IndexState where
pretty IndexStateHead = Disp.text "HEAD"
pretty (IndexStateTime ts) = pretty ts
parseTime = IndexStateTime `fmap` parse
instance Parsec IndexState where
parsec = parseHead <|> parseTime where
parseHead = IndexStateHead <$ P.string "HEAD"
parseTime = IndexStateTime <$> parsec
......@@ -886,7 +886,7 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
[ do dotCabal <- getCabalDir
let logFileName = prettyShow (BuildReports.package report) <.> "log"
logFile = logsDir </> logFileName
reportsDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
reportsDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)
reportFile = reportsDir </> logFileName
handleMissingLogFile $ do
......
......@@ -27,8 +27,8 @@ import Distribution.Deprecated.ParseUtils (parseFlagAssignment)
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Types
( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo
, AllowNewer(..), AllowOlder(..) )
( RepoName (..), RemoteRepo(..), LocalRepo (..), emptyRemoteRepo
, AllowNewer(..), AllowOlder(..), unRepoName )
import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
import Distribution.Client.Config
......@@ -1397,7 +1397,7 @@ programDbOptions progDb showOrParseArgs get' set =
remoteRepoSectionDescr :: SectionDescr GlobalFlags
remoteRepoSectionDescr = SectionDescr
{ sectionName = "repository"
, sectionEmpty = emptyRemoteRepo ""
, sectionEmpty = emptyRemoteRepo (RepoName "")
, sectionFields = remoteRepoFields
, sectionSubsections = []
, sectionGet = getS
......@@ -1406,9 +1406,9 @@ remoteRepoSectionDescr = SectionDescr
where
getS :: GlobalFlags -> [(String, RemoteRepo)]
getS gf =
map (\x->(remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))
map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))
++
map (\x->(localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))
map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))
setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags
setS lineno reponame repo0 conf = do
......
......@@ -60,10 +60,6 @@ module Distribution.Client.Setup
, parsePackageArgs
, liftOptions
, yesNoOpt
--TODO: stop exporting these:
, showRemoteRepo
, parseRemoteRepo
, readRemoteRepo
) where
import Prelude ()
......@@ -73,7 +69,7 @@ import Distribution.Deprecated.ReadP (readP_to_E)
import Distribution.Client.Types
( Username(..), Password(..), RemoteRepo(..)
, LocalRepo (..), emptyLocalRepo
, LocalRepo (..)
, AllowNewer(..), AllowOlder(..), RelaxDeps(..)
, WriteGhcEnvironmentFilesPolicy(..)
)
......@@ -89,6 +85,8 @@ import Distribution.Client.Targets
( UserConstraint, readUserConstraint )
import Distribution.Utils.NubList
( NubList, toNubList, fromNubList)
import Distribution.Parsec (simpleParsec, parsec)
import Distribution.Pretty (prettyShow)
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Settings
......@@ -131,9 +129,9 @@ import Distribution.System ( Platform )
import Distribution.Deprecated.Text
( Text(..), display )
import Distribution.ReadE
( ReadE(..), succeedReadE )
( ReadE(..), succeedReadE, parsecToReadE )
import qualified Distribution.Deprecated.ReadP as Parse
( ReadP, char, munch1, pfail, sepBy1, (+++) )
( ReadP, char, sepBy1, (+++) )
import Distribution.Deprecated.ParseUtils
( readPToMaybe )
import Distribution.Verbosity
......@@ -151,8 +149,6 @@ import Data.List
import qualified Data.Set as Set
import System.FilePath
( (</>) )
import Network.URI
( parseAbsoluteURI, uriToString )
globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI {
......@@ -1367,12 +1363,12 @@ updateCommand = CommandUI {
"Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++
"(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")
updateIndexState (\v flags -> flags { updateIndexState = v })
(reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++
(reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++
"unix-timestamps (e.g. '@1474732068'), " ++
"a ISO8601 UTC timestamp " ++
"(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")
(toFlag `fmap` parse))
(flagToList . fmap display))
(toFlag `fmap` parsec))
(flagToList . fmap prettyShow))
]
}
......@@ -1592,12 +1588,12 @@ getCommand = CommandUI {
"This determines which package versions are available as well as " ++
".cabal file revision is selected (unless --pristine is used).")
getIndexState (\v flags -> flags { getIndexState = v })
(reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++
(reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++
"unix-timestamps (e.g. '@1474732068'), " ++
"a ISO8601 UTC timestamp " ++
"(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")
(toFlag `fmap` parse))
(flagToList . fmap display))
(toFlag `fmap` parsec))
(flagToList . fmap prettyShow))
, option [] ["pristine"]
("Unpack the original pristine tarball, rather than updating the "
......@@ -2081,12 +2077,12 @@ installOptions showOrParseArgs =
"Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++
"(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")