Skip to content

Commit 2edc556

Browse files
Ericson2314Ericson2314
committed
cabal-install: Use UnqualComponentName instead of String
1 parent 0fa05cf commit 2edc556

12 files changed

+86
-68
lines changed

‎cabal-install/Distribution/Client/BuildTarget.hs

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,8 @@ module Distribution.Client.BuildTarget (
4242
) where
4343

4444
import Distribution.Package
45-
( Package(..), PackageId, PackageName, packageName )
45+
( Package(..), PackageId, PackageName, packageName
46+
, unUnqualComponentName )
4647
import Distribution.Client.Types
4748
( PackageLocation(..) )
4849

@@ -1123,11 +1124,11 @@ selectComponentInfo pinfo pkg =
11231124

11241125
componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
11251126
componentStringName pkg CLibName = display (packageName pkg)
1126-
componentStringName _ (CSubLibName name) = name
1127-
componentStringName _ (CFLibName name) = name
1128-
componentStringName _ (CExeName name) = name
1129-
componentStringName _ (CTestName name) = name
1130-
componentStringName _ (CBenchName name) = name
1127+
componentStringName _ (CSubLibName name) = unUnqualComponentName name
1128+
componentStringName _ (CFLibName name) = unUnqualComponentName name
1129+
componentStringName _ (CExeName name) = unUnqualComponentName name
1130+
componentStringName _ (CTestName name) = unUnqualComponentName name
1131+
componentStringName _ (CBenchName name) = unUnqualComponentName name
11311132

11321133
componentModules :: Component -> [ModuleName]
11331134
-- I think it's unlikely users will ask to build a requirement

‎cabal-install/Distribution/Client/DistDirLayout.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -121,9 +121,9 @@ defaultDistDirLayout projectRootDirectory =
121121
display (distParamCompilerId params) </>
122122
display (distParamPackageId params) </>
123123
(case fmap componentNameString (distParamComponentName params) of
124-
Nothing -> ""
125-
Just Nothing -> ""
126-
Just (Just str) -> "c" </> str) </>
124+
Nothing -> ""
125+
Just Nothing -> ""
126+
Just (Just name) -> "c" </> display name) </>
127127
(case distParamOptimization params of
128128
NoOptimisation -> "noopt"
129129
NormalOptimisation -> ""

‎cabal-install/Distribution/Client/Install.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -963,14 +963,14 @@ symlinkBinaries verbosity platform comp configFlags installFlags
963963
[(_, exe, path)] ->
964964
warn verbosity $
965965
"could not create a symlink in " ++ bindir ++ " for "
966-
++ exe ++ " because the file exists there already but is not "
966+
++ display exe ++ " because the file exists there already but is not "
967967
++ "managed by cabal. You can create a symlink for this executable "
968968
++ "manually if you wish. The executable file has been installed at "
969969
++ path
970970
exes ->
971971
warn verbosity $
972972
"could not create symlinks in " ++ bindir ++ " for "
973-
++ intercalate ", " [ exe | (_, exe, _) <- exes ]
973+
++ intercalate ", " [ display exe | (_, exe, _) <- exes ]
974974
++ " because the files exist there already and are not "
975975
++ "managed by cabal. You can create symlinks for these executables "
976976
++ "manually if you wish. The executable files have been installed at "
@@ -1590,7 +1590,7 @@ withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do
15901590
[ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension
15911591
| exe <- PackageDescription.executables pkg
15921592
, PackageDescription.buildable (PackageDescription.buildInfo exe)
1593-
, let exeName = prefix ++ PackageDescription.exeName exe ++ suffix
1593+
, let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix
15941594
prefix = substTemplate prefixTemplate
15951595
suffix = substTemplate suffixTemplate ]
15961596
where

‎cabal-install/Distribution/Client/InstallSymlink.hs

Lines changed: 23 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,8 @@ import Distribution.Solver.Types.SourcePackage
5050
import Distribution.Solver.Types.OptionalStanza
5151

5252
import Distribution.Package
53-
( PackageIdentifier, Package(packageId), UnitId, installedUnitId )
53+
( PackageIdentifier, UnqualComponentName, unUnqualComponentName
54+
, Package(packageId), UnitId, installedUnitId )
5455
import Distribution.Compiler
5556
( CompilerId(..) )
5657
import qualified Distribution.PackageDescription as PackageDescription
@@ -65,6 +66,8 @@ import Distribution.Simple.Compiler
6566
( Compiler, compilerInfo, CompilerInfo(..) )
6667
import Distribution.System
6768
( Platform )
69+
import Distribution.Text
70+
( display )
6871

6972
import System.Posix.Files
7073
( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
@@ -108,7 +111,7 @@ symlinkBinaries :: Platform -> Compiler
108111
-> InstallFlags
109112
-> InstallPlan
110113
-> BuildOutcomes
111-
-> IO [(PackageIdentifier, String, FilePath)]
114+
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
112115
symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
113116
case flagToMaybe (installSymlinkBinDir installFlags) of
114117
Nothing -> return []
@@ -132,7 +135,7 @@ symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
132135
-- This is a bit dodgy; probably won't work for Backpack packages
133136
ipid = installedUnitId rpkg
134137
publicExeName = PackageDescription.exeName exe
135-
privateExeName = prefix ++ publicExeName ++ suffix
138+
privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix
136139
prefix = substTemplate pkgid ipid prefixTemplate
137140
suffix = substTemplate pkgid ipid suffixTemplate ]
138141
where
@@ -182,30 +185,32 @@ symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =
182185
cinfo = compilerInfo comp
183186
(CompilerId compilerFlavor _) = compilerInfoId cinfo
184187

185-
symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir
186-
-- eg @/home/user/bin@
187-
-> FilePath -- ^ The canonical path of the private bin dir
188-
-- eg @/home/user/.cabal/bin@
189-
-> String -- ^ The name of the executable to go in the public
190-
-- bin dir, eg @foo@
191-
-> String -- ^ The name of the executable to in the private bin
192-
-- dir, eg @foo-1.0@
193-
-> IO Bool -- ^ If creating the symlink was successful. @False@
194-
-- if there was another file there already that we
195-
-- did not own. Other errors like permission errors
196-
-- just propagate as exceptions.
188+
symlinkBinary ::
189+
FilePath -- ^ The canonical path of the public bin dir eg
190+
-- @/home/user/bin@
191+
-> FilePath -- ^ The canonical path of the private bin dir eg
192+
-- @/home/user/.cabal/bin@
193+
-> UnqualComponentName -- ^ The name of the executable to go in the public bin
194+
-- dir, eg @foo@
195+
-> String -- ^ The name of the executable to in the private bin
196+
-- dir, eg @foo-1.0@
197+
-> IO Bool -- ^ If creating the symlink was successful. @False@ if
198+
-- there was another file there already that we did
199+
-- not own. Other errors like permission errors just
200+
-- propagate as exceptions.
197201
symlinkBinary publicBindir privateBindir publicName privateName = do
198-
ok <- targetOkToOverwrite (publicBindir </> publicName)
202+
ok <- targetOkToOverwrite (publicBindir </> publicName')
199203
(privateBindir </> privateName)
200204
case ok of
201205
NotOurFile -> return False
202206
NotExists -> mkLink >> return True
203207
OkToOverwrite -> rmLink >> mkLink >> return True
204208
where
209+
publicName' = display publicName
205210
relativeBindir = makeRelative publicBindir privateBindir
206211
mkLink = createSymbolicLink (relativeBindir </> privateName)
207-
(publicBindir </> publicName)
208-
rmLink = removeLink (publicBindir </> publicName)
212+
(publicBindir </> publicName')
213+
rmLink = removeLink (publicBindir </> publicName')
209214

210215
-- | Check a file path of a symlink that we would like to create to see if it
211216
-- is OK. For it to be OK to overwrite it must either not already exist yet or

‎cabal-install/Distribution/Client/List.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,8 @@ module Distribution.Client.List (
1414
) where
1515

1616
import Distribution.Package
17-
( PackageName, Package(..), packageName, packageVersion
17+
( PackageName, UnqualComponentName
18+
, Package(..), packageName, packageVersion
1819
, Dependency(..), simplifyDependency
1920
, UnitId )
2021
import Distribution.ModuleName (ModuleName)
@@ -287,7 +288,7 @@ data PackageDisplayInfo = PackageDisplayInfo {
287288
flags :: [Flag],
288289
hasLib :: Bool,
289290
hasExe :: Bool,
290-
executables :: [String],
291+
executables :: [UnqualComponentName],
291292
modules :: [ModuleName],
292293
haddockHtml :: FilePath,
293294
haveTarball :: Bool
@@ -348,7 +349,7 @@ showPackageDetailedInfo pkginfo =
348349
, entry "Author" author hideIfNull reflowLines
349350
, entry "Maintainer" maintainer hideIfNull reflowLines
350351
, entry "Source repo" sourceRepo orNotSpecified text
351-
, entry "Executables" executables hideIfNull (commaSep text)
352+
, entry "Executables" executables hideIfNull (commaSep disp)
352353
, entry "Flags" flags hideIfNull (commaSep dispFlag)
353354
, entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
354355
, entry "Documentation" haddockHtml showIfInstalled text

‎cabal-install/Distribution/Client/PackageUtils.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ module Distribution.Client.PackageUtils (
1515
) where
1616

1717
import Distribution.Package
18-
( packageVersion, packageName, Dependency(..), unPackageName )
18+
( packageVersion, packageName, Dependency(..), packageNameToUnqualComponentName )
1919
import Distribution.PackageDescription
2020
( PackageDescription(..), libName )
2121
import Distribution.Version
@@ -32,5 +32,5 @@ externalBuildDepends pkg = filter (not . internal) (buildDepends pkg)
3232
internal (Dependency depName versionRange) =
3333
(depName == packageName pkg &&
3434
packageVersion pkg `withinRange` versionRange) ||
35-
(Just (unPackageName depName) `elem` map libName (subLibraries pkg) &&
35+
(Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) &&
3636
isAnyVersion versionRange)

‎cabal-install/Distribution/Client/ProjectPlanOutput.hs

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -161,19 +161,19 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
161161
["bin-file" J..= J.String bin]
162162
where
163163
bin = if elabBuildStyle elab == BuildInplaceOnly
164-
then dist_dir </> "build" </> s </> s
165-
else InstallDirs.bindir (elabInstallDirs elab) </> s
164+
then dist_dir </> "build" </> display s </> display s
165+
else InstallDirs.bindir (elabInstallDirs elab) </> display s
166166

167167
-- TODO: maybe move this helper to "ComponentDeps" module?
168168
-- Or maybe define a 'Text' instance?
169169
comp2str :: ComponentDeps.Component -> String
170170
comp2str c = case c of
171171
ComponentDeps.ComponentLib -> "lib"
172-
ComponentDeps.ComponentSubLib s -> "lib:" <> s
173-
ComponentDeps.ComponentFLib s -> "flib:" <> s
174-
ComponentDeps.ComponentExe s -> "exe:" <> s
175-
ComponentDeps.ComponentTest s -> "test:" <> s
176-
ComponentDeps.ComponentBench s -> "bench:" <> s
172+
ComponentDeps.ComponentSubLib s -> "lib:" <> display s
173+
ComponentDeps.ComponentFLib s -> "flib:" <> display s
174+
ComponentDeps.ComponentExe s -> "exe:" <> display s
175+
ComponentDeps.ComponentTest s -> "test:" <> display s
176+
ComponentDeps.ComponentBench s -> "bench:" <> display s
177177
ComponentDeps.ComponentSetup -> "setup"
178178

179179
style2str :: Bool -> BuildStyle -> String

‎cabal-install/Distribution/Client/ProjectPlanning.hs

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1208,7 +1208,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
12081208
= distBuildDirectory
12091209
(elabDistDirParams elaboratedSharedConfig elab) </>
12101210
"build" </> case Cabal.componentNameString cname of
1211-
Just n -> n
1211+
Just n -> display n
12121212
Nothing -> ""
12131213
| otherwise
12141214
= InstallDirs.bindir install_dirs
@@ -1234,7 +1234,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
12341234
display pkgid ++ "-inplace" ++
12351235
(case Cabal.componentNameString cname of
12361236
Nothing -> ""
1237-
Just s -> "-" ++ s)
1237+
Just s -> "-" ++ display s)
12381238
BuildAndInstall ->
12391239
hashedInstalledPackageId
12401240
(packageHashInputs
@@ -1374,7 +1374,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
13741374
ElabComponent comp ->
13751375
case fmap Cabal.componentNameString
13761376
(compComponentName comp) of
1377-
Just (Just n) -> n
1377+
Just (Just n) -> display n
13781378
_ -> ""
13791379
else InstallDirs.bindir (elabInstallDirs elab)]
13801380
get_exe_path (InstallPlan.Installed _) = unexpectedState
@@ -2196,7 +2196,9 @@ pruneInstallPlanPass2 pkgs =
21962196
exeTargetsRequiredForRevDeps =
21972197
-- TODO: allow requesting executable with different name
21982198
-- than package name
2199-
[ ComponentTarget (Cabal.CExeName (unPackageName (packageName (elabPkgSourceId elab))))
2199+
[ ComponentTarget (Cabal.CExeName
2200+
$ packageNameToUnqualComponentName
2201+
$ packageName $ elabPkgSourceId elab)
22002202
WholeComponent
22012203
| installedUnitId elab `Set.member` hasReverseExeDeps
22022204
]

‎cabal-install/Distribution/Client/Run.hs

Lines changed: 18 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,9 @@ import Distribution.Types.LocalBuildInfo (componentNameTargets')
1818

1919
import Distribution.Client.Utils (tryCanonicalizePath)
2020

21+
import Distribution.Package (UnqualComponentName,
22+
mkUnqualComponentName,
23+
unUnqualComponentName)
2124
import Distribution.PackageDescription (Executable (..),
2225
TestSuite(..),
2326
Benchmark(..),
@@ -34,6 +37,7 @@ import Distribution.Simple.Utils (die, notice, warn,
3437
addLibraryPath)
3538
import Distribution.System (Platform (..))
3639
import Distribution.Verbosity (Verbosity)
40+
import Distribution.Text (display)
3741

3842
import qualified Distribution.Simple.GHCJS as GHCJS
3943

@@ -69,14 +73,14 @@ splitRunArgs verbosity lbi args =
6973
([] , _) -> Left "Couldn't find any enabled executables."
7074
([exe], []) -> return (False, exe, [])
7175
([exe], (x:xs))
72-
| x == exeName exe -> return (True, exe, xs)
73-
| otherwise -> return (False, exe, args)
74-
(_ , []) -> Left
76+
| x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)
77+
| otherwise -> return (False, exe, args)
78+
(_ , []) -> Left
7579
$ "This package contains multiple executables. "
7680
++ "You must pass the executable name as the first argument "
7781
++ "to 'cabal run'."
7882
(_ , (x:xs)) ->
79-
case find (\exe -> exeName exe == x) enabledExes of
83+
case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of
8084
Nothing -> Left $ "No executable named '" ++ x ++ "'."
8185
Just exe -> return (True, exe, xs)
8286
where
@@ -85,20 +89,20 @@ splitRunArgs verbosity lbi args =
8589
maybeWarning :: Maybe String
8690
maybeWarning = case args of
8791
[] -> Nothing
88-
(x:_) -> lookup x components
92+
(x:_) -> lookup (mkUnqualComponentName x) components
8993
where
90-
components :: [(String, String)] -- Component name, message.
94+
components :: [(UnqualComponentName, String)] -- Component name, message.
9195
components =
92-
[ (name, "The executable '" ++ name ++ "' is disabled.")
96+
[ (name, "The executable '" ++ display name ++ "' is disabled.")
9397
| e <- executables pkg_descr
9498
, not . buildable . buildInfo $ e, let name = exeName e]
9599

96-
++ [ (name, "There is a test-suite '" ++ name ++ "',"
100+
++ [ (name, "There is a test-suite '" ++ display name ++ "',"
97101
++ " but the `run` command is only for executables.")
98102
| t <- testSuites pkg_descr
99103
, let name = testName t]
100104

101-
++ [ (name, "There is a benchmark '" ++ name ++ "',"
105+
++ [ (name, "There is a benchmark '" ++ display name ++ "',"
102106
++ " but the `run` command is only for executables.")
103107
| b <- benchmarks pkg_descr
104108
, let name = benchmarkName b]
@@ -113,16 +117,17 @@ run verbosity lbi exe exeArgs = do
113117
curDir </> dataDir pkg_descr)
114118

115119
(path, runArgs) <-
116-
case compilerFlavor (compiler lbi) of
120+
let exeName' = display $ exeName exe
121+
in case compilerFlavor (compiler lbi) of
117122
GHCJS -> do
118123
let (script, cmd, cmdArgs) =
119124
GHCJS.runCmd (withPrograms lbi)
120-
(buildPref </> exeName exe </> exeName exe)
125+
(buildPref </> exeName' </> exeName')
121126
script' <- tryCanonicalizePath script
122127
return (cmd, cmdArgs ++ [script'])
123128
_ -> do
124129
p <- tryCanonicalizePath $
125-
buildPref </> exeName exe </> (exeName exe <.> exeExtension)
130+
buildPref </> exeName' </> (exeName' <.> exeExtension)
126131
return (p, [])
127132

128133
env <- (dataDirEnvVar:) <$> getEnvironment
@@ -136,5 +141,5 @@ run verbosity lbi exe exeArgs = do
136141
paths <- depLibraryPaths True False lbi clbi
137142
return (addLibraryPath os paths env)
138143
else return env
139-
notice verbosity $ "Running " ++ exeName exe ++ "..."
144+
notice verbosity $ "Running " ++ display (exeName exe) ++ "..."
140145
rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'

‎cabal-install/Distribution/Solver/Modular/IndexConversion.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -121,7 +121,8 @@ convGPD os arch cinfo strfl sexes pi
121121
-- and thus cannot actually be solved over. We'll do this
122122
-- by creating a set of package names which are "internal"
123123
-- and dropping them as we convert.
124-
ipns = S.fromList $ [ mkPackageName nm
124+
125+
ipns = S.fromList $ [ unqualComponentNameToPackageName nm
125126
| (nm, _) <- sub_libs ]
126127

127128
conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->

‎cabal-install/Distribution/Solver/Types/ComponentDeps.hs

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ module Distribution.Solver.Types.ComponentDeps (
3737
) where
3838

3939
import Prelude ()
40+
import Distribution.Package (UnqualComponentName)
4041
import Distribution.Client.Compat.Prelude hiding (empty,zip)
4142

4243
import qualified Data.Map as Map
@@ -51,11 +52,11 @@ import qualified Distribution.Types.ComponentName as CN
5152
-- | Component of a package.
5253
data Component =
5354
ComponentLib
54-
| ComponentSubLib String
55-
| ComponentFLib String
56-
| ComponentExe String
57-
| ComponentTest String
58-
| ComponentBench String
55+
| ComponentSubLib UnqualComponentName
56+
| ComponentFLib UnqualComponentName
57+
| ComponentExe UnqualComponentName
58+
| ComponentTest UnqualComponentName
59+
| ComponentBench UnqualComponentName
5960
| ComponentSetup
6061
deriving (Show, Eq, Ord, Generic)
6162

0 commit comments

Comments
 (0)