Commit 492f7463 authored by Oleg Grenrus's avatar Oleg Grenrus

Remove few more Text instances

parent fa57ddb5
......@@ -49,7 +49,9 @@ import qualified Distribution.Deprecated.Text as Text
import Distribution.Deprecated.ParseUtils
( FieldDescr(..), ParseResult(..), Field(..)
, simpleField, listField, ppFields, readFields
, syntaxError, locatedErrorMsg )
, syntaxError, locatedErrorMsg, simpleFieldParsec )
import Distribution.Pretty (pretty)
import Distribution.Parsec (parsec)
import Distribution.Simple.Utils
( comparing )
......@@ -238,7 +240,7 @@ fieldDescrs =
package (\v r -> r { package = v })
, simpleField "os" Text.disp Text.parse
os (\v r -> r { os = v })
, simpleField "arch" Text.disp Text.parse
, simpleFieldParsec "arch" pretty parsec
arch (\v r -> r { arch = v })
, simpleField "compiler" Text.disp Text.parse
compiler (\v r -> r { compiler = v })
......
......@@ -94,7 +94,9 @@ import Distribution.Deprecated.ParseUtils
, locatedErrorMsg, showPWarning
, readFields, warning, lineNo
, simpleField, listField, spaceListField
, parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError)
, parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError
, simpleFieldParsec
)
import Distribution.Client.ParseUtils
( parseFields, ppFields, ppSection )
import Distribution.Client.HttpUtils
......@@ -115,6 +117,7 @@ import Distribution.Compiler
( CompilerFlavor(..), defaultCompilerFlavor )
import Distribution.Verbosity
( Verbosity, normal )
import qualified Distribution.Compat.CharParsing as P
import Distribution.Solver.Types.ConstraintSource
......@@ -1345,8 +1348,8 @@ remoteRepoFields =
, listField "root-keys"
text parseTokenQ
remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x })
, simpleField "key-threshold"
showThreshold Text.parse
, simpleFieldParsec "key-threshold"
showThreshold P.integral
remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x })
]
where
......
......@@ -36,7 +36,6 @@ import Distribution.Simple.Utils
import Distribution.Verbosity
( Verbosity )
import Distribution.Pretty (prettyShow)
import Distribution.Deprecated.Text (display)
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Program
( programName )
......@@ -171,7 +170,7 @@ unpackPackage :: Verbosity -> FilePath -> PackageId
-> PackageDescriptionOverride
-> FilePath -> IO ()
unpackPackage verbosity prefix pkgid descOverride pkgPath = do
let pkgdirname = display pkgid
let pkgdirname = prettyShow pkgid
pkgdir = prefix </> pkgdirname
pkgdir' = addTrailingPathSeparator pkgdir
emptyDirectory directory = null <$> listDirectory directory
......@@ -190,7 +189,7 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
case descOverride of
Nothing -> return ()
Just pkgtxt -> do
let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"
let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"
info verbosity $
"Updating " ++ descFilePath
++ " with the latest revision from the index."
......@@ -214,37 +213,37 @@ data ClonePackageException =
instance Exception ClonePackageException where
displayException (ClonePackageNoSourceRepos pkgid) =
"Cannot fetch a source repository for package " ++ display pkgid
"Cannot fetch a source repository for package " ++ prettyShow pkgid
++ ". The package does not specify any source repositories."
displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =
"Cannot fetch a source repository for package " ++ display pkgid
"Cannot fetch a source repository for package " ++ prettyShow pkgid
++ ". The package does not specify a source repository of the requested "
++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind
++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind
displayException (ClonePackageNoRepoType pkgid _repo) =
"Cannot fetch the source repository for package " ++ display pkgid
"Cannot fetch the source repository for package " ++ prettyShow pkgid
++ ". The package's description specifies a source repository but does "
++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =
"Cannot fetch the source repository for package " ++ display pkgid
++ ". The repository type '" ++ display repoType
"Cannot fetch the source repository for package " ++ prettyShow pkgid
++ ". The repository type '" ++ prettyShow repoType
++ "' is not yet supported."
displayException (ClonePackageNoRepoLocation pkgid _repo) =
"Cannot fetch the source repository for package " ++ display pkgid
"Cannot fetch the source repository for package " ++ prettyShow pkgid
++ ". The package's description specifies a source repository but does "
++ "not specify the repository 'location' field (i.e. the URL)."
displayException (ClonePackageDestinationExists pkgid dest isdir) =
"Not fetching the source repository for package " ++ display pkgid ++ ". "
"Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "
++ if isdir then "The destination directory " ++ dest ++ " already exists."
else "A file " ++ dest ++ " is in the way."
displayException (ClonePackageFailedWithExitCode
pkgid repo vcsprogname exitcode) =
"Failed to fetch the source repository for package " ++ display pkgid
"Failed to fetch the source repository for package " ++ prettyShow pkgid
++ ", repository location " ++ srpLocation repo ++ " ("
++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
......@@ -302,7 +301,7 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
Left SourceRepoLocationUnspecified ->
throwIO (ClonePackageNoRepoLocation pkgid repo)
let destDir = destDirPrefix </> display (packageName pkgid)
let destDir = destDirPrefix </> prettyShow (packageName pkgid)
destDirExists <- doesDirectoryExist destDir
destFileExists <- doesFileExist destDir
when (destDirExists || destFileExists) $
......
......@@ -44,7 +44,7 @@ import Distribution.Simple.GHC
( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)
, GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile
, writeGhcEnvironmentFile )
import Distribution.Deprecated.Text
import Distribution.Pretty (Pretty, prettyShow)
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, Node)
import qualified Distribution.Compat.Binary as Binary
......@@ -236,19 +236,19 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
["bin-file" J..= J.String bin]
where
bin = if elabBuildStyle elab == BuildInplaceOnly
then dist_dir </> "build" </> display s </> display s
else InstallDirs.bindir (elabInstallDirs elab) </> display s
then dist_dir </> "build" </> prettyShow s </> prettyShow s
else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s
-- TODO: maybe move this helper to "ComponentDeps" module?
-- Or maybe define a 'Text' instance?
comp2str :: ComponentDeps.Component -> String
comp2str c = case c of
ComponentDeps.ComponentLib -> "lib"
ComponentDeps.ComponentSubLib s -> "lib:" <> display s
ComponentDeps.ComponentFLib s -> "flib:" <> display s
ComponentDeps.ComponentExe s -> "exe:" <> display s
ComponentDeps.ComponentTest s -> "test:" <> display s
ComponentDeps.ComponentBench s -> "bench:" <> display s
ComponentDeps.ComponentSubLib s -> "lib:" <> prettyShow s
ComponentDeps.ComponentFLib s -> "flib:" <> prettyShow s
ComponentDeps.ComponentExe s -> "exe:" <> prettyShow s
ComponentDeps.ComponentTest s -> "test:" <> prettyShow s
ComponentDeps.ComponentBench s -> "bench:" <> prettyShow s
ComponentDeps.ComponentSetup -> "setup"
style2str :: Bool -> BuildStyle -> String
......@@ -256,8 +256,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
style2str False BuildInplaceOnly = "inplace"
style2str False BuildAndInstall = "global"
jdisplay :: Text a => a -> J.Value
jdisplay = J.String . display
jdisplay :: Pretty a => a -> J.Value
jdisplay = J.String . prettyShow
-----------------------------------------------------------------------------
......@@ -692,7 +692,7 @@ updatePostBuildProjectStatus verbosity distDirLayout
return currentBuildStatus
where
displayPackageIdSet = intercalate ", " . map display . Set.toList
displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList
-- | Helper for reading the cache file.
--
......@@ -836,7 +836,7 @@ argsEquivalentOfGhcEnvironmentFileGhc
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
-- TODO use proper flags? but packageDbArgsDb is private
clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]
packageIdFlag uid = ["-package-id", display uid]
packageIdFlag uid = ["-package-id", prettyShow uid]
-- We're producing an environment for users to use in ghci, so of course
......
......@@ -100,8 +100,7 @@ import Distribution.Client.Utils
import Distribution.ReadE
import Distribution.System ( Platform(..), buildPlatform )
import Distribution.Deprecated.Text
( display )
import Distribution.Pretty (prettyShow)
import Distribution.Utils.NubList
( toNubListR )
import Distribution.Verbosity
......@@ -477,7 +476,7 @@ runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do
selfExecSetupMethod :: SetupRunner
selfExecSetupMethod verbosity options bt args0 = do
let args = ["act-as-setup",
"--build-type=" ++ display bt,
"--build-type=" ++ prettyShow bt,
"--"] ++ args0
info verbosity $ "Using self-exec internal setup method with build-type "
++ show bt ++ " and args:\n " ++ show args
......@@ -570,7 +569,7 @@ getExternalSetupMethod verbosity options pkg bt = do
++ show (useDependenciesExclusive options)
createDirectoryIfMissingVerbose verbosity True setupDir
(cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse
debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion
debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion
path <- if useCachedSetupExecutable
then getCachedSetupExecutable options'
cabalLibVersion mCabalLibInstalledPkgId
......@@ -728,9 +727,9 @@ getExternalSetupMethod verbosity options pkg bt = do
cabalDepVersion = useCabalVersion options'
options'' = options' { usePackageIndex = Just index }
case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of
[] -> die' verbosity $ "The package '" ++ display (packageName pkg)
[] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg)
++ "' requires Cabal library version "
++ display (useCabalVersion options)
++ prettyShow (useCabalVersion options)
++ " but no suitable version is installed."
pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs
err = error "Distribution.Client.installedCabalVersion: empty version list"
......@@ -799,11 +798,11 @@ getExternalSetupMethod verbosity options pkg bt = do
return (setupCacheDir, cachedSetupProgFile)
where
buildTypeString = show bt
cabalVersionString = "Cabal-" ++ (display cabalLibVersion)
compilerVersionString = display $
cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion
compilerVersionString = prettyShow $
maybe buildCompilerId compilerId
$ useCompiler options'
platformString = display platform
platformString = prettyShow platform
-- | Look up the setup executable in the cache; update the cache if the setup
-- executable is not found.
......
......@@ -39,7 +39,7 @@ module Distribution.Deprecated.ParseUtils (
optsField, liftField, boolField, parseQuoted, parseMaybeQuoted,
readPToMaybe,
fieldParsec, commaNewLineListFieldParsec,
fieldParsec, simpleFieldParsec, commaNewLineListFieldParsec,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -214,6 +214,11 @@ simpleField :: String -> (a -> Doc) -> ReadP a a
simpleField name showF readF get set
= liftField get set $ field name showF readF
simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleFieldParsec name showF readF get set
= liftField get set $ fieldParsec name showF readF
commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListFieldWithSep separator name showF readF get set =
......
......@@ -45,7 +45,6 @@ import qualified Distribution.PackageDescription as D
import qualified Distribution.Simple.Setup as D
import qualified Distribution.System as D
import qualified Distribution.Types.PackageVersionConstraint as D
import qualified Distribution.Types.SourceRepo as D
import qualified Distribution.Types.UnqualComponentName as D
import qualified Distribution.Version as D
import qualified Language.Haskell.Extension as E
......@@ -97,9 +96,6 @@ instance Text Bool where
, (Parse.string "False" Parse.+++
Parse.string "false") >> return False ]
instance Text Int where
parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat
instance Text a => Text (Identity a) where
disp = disp . runIdentity
parse = fmap Identity parse
......@@ -123,20 +119,6 @@ instance Text Version where
-- Instances
-------------------------------------------------------------------------------
instance Text D.Arch where
parse = fmap (D.classifyArch D.Strict) ident
instance Text D.BuildType where
parse = do
name <- Parse.munch1 isAlphaNum
case name of
"Simple" -> return D.Simple
"Configure" -> return D.Configure
"Custom" -> return D.Custom
"Make" -> return D.Make
"Default" -> return D.Custom
_ -> fail ("unknown build-type: '" ++ name ++ "'")
instance Text D.CompilerFlavor where
parse = do
comp <- Parse.munch1 isAlphaNum
......@@ -275,12 +257,6 @@ instance Text D.Platform where
where firstChar = Parse.satisfy isAlpha
rest = Parse.munch (\c -> isAlphaNum c || c == '_')
instance Text D.RepoKind where
parse = fmap D.classifyRepoKind ident
instance Text D.RepoType where
parse = fmap D.classifyRepoType ident
instance Text D.UnqualComponentName where
parse = D.mkUnqualComponentName <$> parsePackageName
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment