Skip to content

Commit 2cd5ac2

Browse files
Ericson2314Ericson2314
committed
WIP yak introducing UnqualComponentName
1 parent 80de7ff commit 2cd5ac2

31 files changed

+278
-219
lines changed

‎Cabal/Distribution/Backpack/ComponentsGraph.hs

Lines changed: 11 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -51,24 +51,22 @@ toComponentsGraph enabled pkg_descr =
5151
where
5252
-- The dependencies for the given component
5353
componentDeps component =
54-
[ CExeName toolname | Dependency pkgname _
55-
<- buildTools bi
56-
, let toolname = unPackageName pkgname
57-
, toolname `elem` map exeName
58-
(executables pkg_descr) ]
54+
[ CExeName toolname
55+
| Dependency pkgname _ <- buildTools bi
56+
, let toolname = packageNameToUnqualComponentName pkgname
57+
, toolname `elem` map exeName (executables pkg_descr) ]
5958

6059
++ [ if pkgname == packageName pkg_descr
61-
then CLibName
62-
else CSubLibName toolname
63-
| Dependency pkgname _
64-
<- targetBuildDepends bi
65-
, pkgname `elem` internalPkgDeps
66-
, let toolname = unPackageName pkgname ]
60+
then CLibName
61+
else CSubLibName toolname
62+
| Dependency pkgname _ <- targetBuildDepends bi
63+
, let toolname = packageNameToUnqualComponentName pkgname
64+
, toolname `elem` internalPkgDeps ]
6765
where
6866
bi = componentBuildInfo component
6967
internalPkgDeps = map (conv . libName) (allLibraries pkg_descr)
70-
conv Nothing = packageName pkg_descr
71-
conv (Just s) = mkPackageName s
68+
conv Nothing = packageNameToUnqualComponentName $ packageName pkg_descr
69+
conv (Just s) = s
7270

7371
-- | Error message when there is a cycle; takes the SCC of components.
7472
componentCycleMsg :: [ComponentName] -> Doc

‎Cabal/Distribution/Backpack/ConfiguredComponent.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -104,7 +104,7 @@ mkConfiguredComponent this_pid this_cid lib_deps exe_deps component =
104104

105105
type ConfiguredComponentMap =
106106
(Map PackageName (ComponentId, PackageId), -- libraries
107-
Map String ComponentId) -- executables
107+
Map UnqualComponentName ComponentId) -- executables
108108

109109
-- Executable map must be different because an executable can
110110
-- have the same name as a library. Ew.
@@ -141,7 +141,7 @@ toConfiguredComponent pkg_descr this_cid
141141
= Map.toList external_lib_map
142142
exe_deps = [ cid
143143
| Dependency pkgname _ <- buildTools bi
144-
, let name = unPackageName pkgname
144+
, let name = packageNameToUnqualComponentName pkgname
145145
, Just cid <- [ Map.lookup name exe_map ] ]
146146

147147
-- | Also computes the 'ComponentId', and sets cc_public if necessary.
@@ -183,7 +183,8 @@ extendConfiguredComponentMap cc (lib_map, exe_map) =
183183
Map.insert (pkgName (cc_pkgid cc))
184184
(cc_cid cc, cc_pkgid cc) lib_map
185185
CSubLibName str ->
186-
Map.insert (mkPackageName str)
186+
-- TODO roundtrip
187+
Map.insert (mkPackageName $ unUnqualComponentName str)
187188
(cc_cid cc, cc_pkgid cc) lib_map
188189
_ -> lib_map
189190
exe_map'

‎Cabal/Distribution/Backpack/Id.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,7 @@ computeComponentId mb_ipid mb_cid pid cname mb_details =
6363
NoFlag -> mkComponentId $ actual_base
6464
++ (case componentNameString cname of
6565
Nothing -> ""
66-
Just s -> "-" ++ s)
66+
Just s -> "-" ++ unUnqualComponentName s)
6767

6868
-- | Computes the package name for a library. If this is the public
6969
-- library, it will just be the original package name; otherwise,
@@ -102,7 +102,8 @@ computeCompatPackageName pkg_name CLibName = pkg_name
102102
computeCompatPackageName pkg_name cname
103103
= mkPackageName $ "z-" ++ zdashcode (display pkg_name)
104104
++ (case componentNameString cname of
105-
Just cname_str -> "-z-" ++ zdashcode cname_str
105+
Just cname_u -> "-z-" ++ zdashcode cname_str
106+
where cname_str = unUnqualComponentName cname_u
106107
Nothing -> "")
107108

108109
zdashcode :: String -> String

‎Cabal/Distribution/Package.hs

Lines changed: 47 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,8 @@
1818

1919
module Distribution.Package (
2020
-- * Package ids
21-
PackageName, unPackageName, mkPackageName,
21+
UnqualComponentName, unUnqualComponentName, mkUnqualComponentName,
22+
PackageName, unPackageName, mkPackageName, packageNameToUnqualComponentName,
2223
PackageIdentifier(..),
2324
PackageId,
2425

@@ -69,6 +70,44 @@ import Distribution.ModuleName
6970

7071
import Text.PrettyPrint ((<+>), text)
7172

73+
-- | A Component name, or other similarly-parsed identifier.
74+
--
75+
newtype UnqualComponentName = UnqualComponentName ShortText
76+
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,
77+
Semigroup, Monoid) -- TODO: bad enabler of bad monoids
78+
79+
-- | Convert 'UnqualComponentName' to 'String'
80+
unUnqualComponentName :: UnqualComponentName -> String
81+
unUnqualComponentName (UnqualComponentName s) = fromShortText s
82+
83+
-- | Construct a 'UnqualComponentName' from a 'String'
84+
--
85+
-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName'
86+
--
87+
-- Note: No validations are performed to ensure that the resulting
88+
-- 'UnqualComponentName' is valid
89+
--
90+
-- @since 2.0
91+
mkUnqualComponentName :: String -> UnqualComponentName
92+
mkUnqualComponentName = UnqualComponentName . toShortText
93+
94+
instance Binary UnqualComponentName
95+
96+
instance Text UnqualComponentName where
97+
disp = Disp.text . unUnqualComponentName
98+
parse = do
99+
ns <- Parse.sepBy1 component (Parse.char '-')
100+
return (mkUnqualComponentName (intercalate "-" ns))
101+
where
102+
component = do
103+
cs <- Parse.munch1 isAlphaNum
104+
if all isDigit cs then Parse.pfail else return cs
105+
-- each component must contain an alphabetic character, to avoid
106+
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
107+
108+
instance NFData UnqualComponentName where
109+
rnf (UnqualComponentName pkg) = rnf pkg
110+
72111
-- | A package name.
73112
--
74113
-- Use 'mkPackageName' and 'unPackageName' to convert from/to a
@@ -77,12 +116,15 @@ import Text.PrettyPrint ((<+>), text)
77116
-- This type is opaque since @Cabal-2.0@
78117
--
79118
-- @since 2.0
80-
newtype PackageName = PackageName ShortText
81-
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
119+
newtype PackageName = PackageName UnqualComponentName
120+
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,
121+
Binary, Text, NFData)
122+
123+
packageNameToUnqualComponentName (PackageName n) = n
82124

83125
-- | Convert 'PackageName' to 'String'
84126
unPackageName :: PackageName -> String
85-
unPackageName (PackageName s) = fromShortText s
127+
unPackageName = unUnqualComponentName . packageNameToUnqualComponentName
86128

87129
-- | Construct a 'PackageName' from a 'String'
88130
--
@@ -93,24 +135,7 @@ unPackageName (PackageName s) = fromShortText s
93135
--
94136
-- @since 2.0
95137
mkPackageName :: String -> PackageName
96-
mkPackageName = PackageName . toShortText
97-
98-
instance Binary PackageName
99-
100-
instance Text PackageName where
101-
disp = Disp.text . unPackageName
102-
parse = do
103-
ns <- Parse.sepBy1 component (Parse.char '-')
104-
return (mkPackageName (intercalate "-" ns))
105-
where
106-
component = do
107-
cs <- Parse.munch1 isAlphaNum
108-
if all isDigit cs then Parse.pfail else return cs
109-
-- each component must contain an alphabetic character, to avoid
110-
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
111-
112-
instance NFData PackageName where
113-
rnf (PackageName pkg) = rnf pkg
138+
mkPackageName = PackageName . mkUnqualComponentName
114139

115140
-- | Type alias so we can use the shorter name PackageId.
116141
type PackageId = PackageIdentifier

‎Cabal/Distribution/PackageDescription/Check.hs

Lines changed: 14 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -185,13 +185,15 @@ checkSanity pkg =
185185
++ "Only the non-internal library can have the same name as the package."
186186

187187
, check (not (null duplicateNames)) $
188-
PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames
188+
PackageBuildImpossible $ "Duplicate sections: "
189+
++ commaSep (unUnqualComponentName <$> duplicateNames)
189190
++ ". The name of every library, executable, test suite,"
190191
++ " and benchmark section in"
191192
++ " the package must be unique."
192193

193194
-- NB: but it's OK for executables to have the same name!
194-
, check (any (== display (packageName pkg)) subLibNames) $
195+
-- TODO shouldn't need to compare on the string level
196+
, check (any (== display (packageName pkg)) (display <$> subLibNames)) $
195197
PackageBuildImpossible $ "Illegal internal library name "
196198
++ display (packageName pkg)
197199
++ ". Internal libraries cannot have the same name as the package."
@@ -239,7 +241,7 @@ checkLibrary pkg lib =
239241
PackageDistSuspiciousWarn $
240242
"Library " ++ (case libName lib of
241243
Nothing -> ""
242-
Just n -> n
244+
Just n -> display n
243245
) ++ "does not expose any modules"
244246

245247
-- check use of signatures sections
@@ -273,7 +275,7 @@ checkExecutable pkg exe =
273275

274276
check (null (modulePath exe)) $
275277
PackageBuildImpossible $
276-
"No 'main-is' field found for executable " ++ exeName exe
278+
"No 'main-is' field found for executable " ++ display (exeName exe)
277279

278280
, check (not (null (modulePath exe))
279281
&& (not $ fileExtensionSupportedLanguage $ modulePath exe)) $
@@ -291,14 +293,14 @@ checkExecutable pkg exe =
291293

292294
, check (not (null moduleDuplicates)) $
293295
PackageBuildImpossible $
294-
"Duplicate modules in executable '" ++ exeName exe ++ "': "
296+
"Duplicate modules in executable '" ++ display (exeName exe) ++ "': "
295297
++ commaSep (map display moduleDuplicates)
296298

297299
-- check that all autogen-modules appear on other-modules
298300
, check
299301
(not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $
300302
PackageBuildImpossible $
301-
"On executable '" ++ exeName exe ++ "' an 'autogen-module' is not "
303+
"On executable '" ++ display (exeName exe) ++ "' an 'autogen-module' is not "
302304
++ "on 'other-modules'"
303305

304306
]
@@ -325,7 +327,7 @@ checkTestSuite pkg test =
325327

326328
, check (not $ null moduleDuplicates) $
327329
PackageBuildImpossible $
328-
"Duplicate modules in test suite '" ++ testName test ++ "': "
330+
"Duplicate modules in test suite '" ++ display (testName test) ++ "': "
329331
++ commaSep (map display moduleDuplicates)
330332

331333
, check mainIsWrongExt $
@@ -346,7 +348,7 @@ checkTestSuite pkg test =
346348
(testModulesAutogen test)
347349
) $
348350
PackageBuildImpossible $
349-
"On test suite '" ++ testName test ++ "' an 'autogen-module' is not "
351+
"On test suite '" ++ display (testName test) ++ "' an 'autogen-module' is not "
350352
++ "on 'other-modules'"
351353
]
352354
where
@@ -380,7 +382,7 @@ checkBenchmark _pkg bm =
380382

381383
, check (not $ null moduleDuplicates) $
382384
PackageBuildImpossible $
383-
"Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "
385+
"Duplicate modules in benchmark '" ++ display (benchmarkName bm) ++ "': "
384386
++ commaSep (map display moduleDuplicates)
385387

386388
, check mainIsWrongExt $
@@ -395,7 +397,7 @@ checkBenchmark _pkg bm =
395397
(benchmarkModulesAutogen bm)
396398
) $
397399
PackageBuildImpossible $
398-
"On benchmark '" ++ benchmarkName bm ++ "' an 'autogen-module' is "
400+
"On benchmark '" ++ display (benchmarkName bm) ++ "' an 'autogen-module' is "
399401
++ "not on 'other-modules'"
400402
]
401403
where
@@ -552,7 +554,8 @@ checkFields pkg =
552554
, isNoVersion vr ]
553555

554556
internalLibraries =
555-
map (maybe (packageName pkg) mkPackageName . libName)
557+
-- TODO, avoid around trip
558+
map (maybe (packageName pkg) (mkPackageName . unUnqualComponentName) . libName)
556559
(allLibraries pkg)
557560
buildDependsRangeOnInternalLibrary =
558561
[ dep

‎Cabal/Distribution/PackageDescription/Configuration.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -452,7 +452,7 @@ constrainBy left extra =
452452

453453
-- | Collect up the targets in a TargetSet of tagged targets, storing the
454454
-- dependencies as we go.
455-
flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Component)])
455+
flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)])
456456
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
457457
where
458458
untag (_, Lib _) (Just _, _) = userBug "Only one library expected"
@@ -464,7 +464,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
464464
}
465465
untag (deps, SubComp n c) (mb_lib, comps)
466466
| any ((== n) . fst) comps =
467-
userBug $ "There exist several components with the same name: '" ++ n ++ "'"
467+
userBug $ "There exist several components with the same name: '" ++ unUnqualComponentName n ++ "'"
468468

469469
| otherwise = (mb_lib, (n, c') : comps)
470470
where
@@ -484,7 +484,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
484484
--
485485

486486
data PDTagged = Lib Library
487-
| SubComp String Component
487+
| SubComp UnqualComponentName Component
488488
| PDNull
489489
deriving Show
490490

‎Cabal/Distribution/PackageDescription/Parse.hs

Lines changed: 15 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -889,11 +889,11 @@ parsePackageDescription file = do
889889
-> PM ([SourceRepo], [Flag]
890890
,Maybe SetupBuildInfo
891891
,(Maybe (CondTree ConfVar [Dependency] Library))
892-
,[(String, CondTree ConfVar [Dependency] Library)]
893-
,[(String, CondTree ConfVar [Dependency] ForeignLib)]
894-
,[(String, CondTree ConfVar [Dependency] Executable)]
895-
,[(String, CondTree ConfVar [Dependency] TestSuite)]
896-
,[(String, CondTree ConfVar [Dependency] Benchmark)])
892+
,[(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
893+
,[(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
894+
,[(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
895+
,[(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
896+
,[(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)])
897897
getBody pkg = peekField >>= \mf -> case mf of
898898
Just (Section line_no sec_type sec_label sec_fields)
899899
| sec_type == "executable" -> do
@@ -903,7 +903,7 @@ parsePackageDescription file = do
903903
flds <- collectFields parseExeFields sec_fields
904904
skipField
905905
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
906-
return (repos, flags, csetup, mlib, sub_libs, flibs, (exename, flds): exes, tests, bms)
906+
return (repos, flags, csetup, mlib, sub_libs, flibs, (mkUnqualComponentName exename, flds): exes, tests, bms)
907907

908908
| sec_type == "foreign-library" -> do
909909
when (null sec_label) $ lift $ syntaxError line_no
@@ -922,7 +922,7 @@ parsePackageDescription file = do
922922
then do
923923
skipField
924924
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
925-
return (repos, flags, csetup, mlib, sub_libs, (libname, flds):flibs, exes, tests, bms)
925+
return (repos, flags, csetup, mlib, sub_libs, (mkUnqualComponentName libname, flds):flibs, exes, tests, bms)
926926
else lift $ syntaxError line_no $
927927
"Foreign library \"" ++ libname
928928
++ "\" is missing required field \"type\" or the field "
@@ -948,7 +948,7 @@ parsePackageDescription file = do
948948
skipField
949949
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
950950
return (repos, flags, csetup, mlib, sub_libs, flibs, exes,
951-
(testname, flds) : tests, bms)
951+
(mkUnqualComponentName testname, flds) : tests, bms)
952952
else lift $ syntaxError line_no $
953953
"Test suite \"" ++ testname
954954
++ "\" is missing required field \"type\" or the field "
@@ -974,7 +974,7 @@ parsePackageDescription file = do
974974
skipField
975975
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
976976
return (repos, flags, csetup, mlib, sub_libs, flibs, exes,
977-
tests, (benchname, flds) : bms)
977+
tests, (mkUnqualComponentName benchname, flds) : bms)
978978
else lift $ syntaxError line_no $
979979
"Benchmark \"" ++ benchname
980980
++ "\" is missing required field \"type\" or the field "
@@ -994,7 +994,7 @@ parsePackageDescription file = do
994994
(repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg
995995
case mb_libname of
996996
Just libname ->
997-
return (repos, flags, csetup, mlib, (libname, flds) : sub_libs, flibs, exes, tests, bms)
997+
return (repos, flags, csetup, mlib, (mkUnqualComponentName libname, flds) : sub_libs, flibs, exes, tests, bms)
998998
Nothing -> do
999999
when (isJust mlib) $ lift $ syntaxError line_no
10001000
"There can only be one (public) library section in a package description."
@@ -1141,9 +1141,9 @@ parsePackageDescription file = do
11411141
checkForUndefinedFlags ::
11421142
[Flag] ->
11431143
Maybe (CondTree ConfVar [Dependency] Library) ->
1144-
[(String, CondTree ConfVar [Dependency] Library)] ->
1145-
[(String, CondTree ConfVar [Dependency] Executable)] ->
1146-
[(String, CondTree ConfVar [Dependency] TestSuite)] ->
1144+
[(UnqualComponentName, CondTree ConfVar [Dependency] Library)] ->
1145+
[(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] ->
1146+
[(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] ->
11471147
PM ()
11481148
checkForUndefinedFlags flags mlib sub_libs exes tests = do
11491149
let definedFlags = map flagName flags
@@ -1252,11 +1252,11 @@ parseHookedBuildInfo inp = do
12521252
| lowercase inFieldName /= "executable" = liftM Just (parseBI bi)
12531253
parseLib _ = return Nothing
12541254

1255-
parseExe :: [Field] -> ParseResult (String, BuildInfo)
1255+
parseExe :: [Field] -> ParseResult (UnqualComponentName, BuildInfo)
12561256
parseExe (F line inFieldName mName:bi)
12571257
| lowercase inFieldName == "executable"
12581258
= do bis <- parseBI bi
1259-
return (mName, bis)
1259+
return (mkUnqualComponentName mName, bis)
12601260
| otherwise = syntaxError line "expecting 'executable' at top of stanza"
12611261
parseExe (_:_) = cabalBug "`parseExe' called on a non-field"
12621262
parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"

0 commit comments

Comments
 (0)