diff --git a/Cabal/Distribution/Backpack/ComponentsGraph.hs b/Cabal/Distribution/Backpack/ComponentsGraph.hs index c96dd78f9a3..5f716373714 100644 --- a/Cabal/Distribution/Backpack/ComponentsGraph.hs +++ b/Cabal/Distribution/Backpack/ComponentsGraph.hs @@ -51,24 +51,22 @@ toComponentsGraph enabled pkg_descr = where -- The dependencies for the given component componentDeps component = - [ CExeName toolname | Dependency pkgname _ - <- buildTools bi - , let toolname = unPackageName pkgname - , toolname `elem` map exeName - (executables pkg_descr) ] + [ CExeName toolname + | Dependency pkgname _ <- buildTools bi + , let toolname = packageNameToUnqualComponentName pkgname + , toolname `elem` map exeName (executables pkg_descr) ] ++ [ if pkgname == packageName pkg_descr - then CLibName - else CSubLibName toolname - | Dependency pkgname _ - <- targetBuildDepends bi - , pkgname `elem` internalPkgDeps - , let toolname = unPackageName pkgname ] + then CLibName + else CSubLibName toolname + | Dependency pkgname _ <- targetBuildDepends bi + , let toolname = packageNameToUnqualComponentName pkgname + , toolname `elem` internalPkgDeps ] where bi = componentBuildInfo component internalPkgDeps = map (conv . libName) (allLibraries pkg_descr) - conv Nothing = packageName pkg_descr - conv (Just s) = mkPackageName s + conv Nothing = packageNameToUnqualComponentName $ packageName pkg_descr + conv (Just s) = s -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: [ComponentName] -> Doc diff --git a/Cabal/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/Distribution/Backpack/ConfiguredComponent.hs index 94035546bda..ddf550ad224 100644 --- a/Cabal/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/Distribution/Backpack/ConfiguredComponent.hs @@ -104,7 +104,7 @@ mkConfiguredComponent this_pid this_cid lib_deps exe_deps component = type ConfiguredComponentMap = (Map PackageName (ComponentId, PackageId), -- libraries - Map String ComponentId) -- executables + Map UnqualComponentName ComponentId) -- executables -- Executable map must be different because an executable can -- have the same name as a library. Ew. @@ -141,7 +141,7 @@ toConfiguredComponent pkg_descr this_cid = Map.toList external_lib_map exe_deps = [ cid | Dependency pkgname _ <- buildTools bi - , let name = unPackageName pkgname + , let name = packageNameToUnqualComponentName pkgname , Just cid <- [ Map.lookup name exe_map ] ] -- | Also computes the 'ComponentId', and sets cc_public if necessary. @@ -183,7 +183,7 @@ extendConfiguredComponentMap cc (lib_map, exe_map) = Map.insert (pkgName (cc_pkgid cc)) (cc_cid cc, cc_pkgid cc) lib_map CSubLibName str -> - Map.insert (mkPackageName str) + Map.insert (unqualComponentNameToPackageName str) (cc_cid cc, cc_pkgid cc) lib_map _ -> lib_map exe_map' diff --git a/Cabal/Distribution/Backpack/Id.hs b/Cabal/Distribution/Backpack/Id.hs index 830d3683be5..a299163624f 100644 --- a/Cabal/Distribution/Backpack/Id.hs +++ b/Cabal/Distribution/Backpack/Id.hs @@ -63,7 +63,7 @@ computeComponentId mb_ipid mb_cid pid cname mb_details = NoFlag -> mkComponentId $ actual_base ++ (case componentNameString cname of Nothing -> "" - Just s -> "-" ++ s) + Just s -> "-" ++ unUnqualComponentName s) -- | Computes the package name for a library. If this is the public -- library, it will just be the original package name; otherwise, @@ -102,7 +102,8 @@ computeCompatPackageName pkg_name CLibName = pkg_name computeCompatPackageName pkg_name cname = mkPackageName $ "z-" ++ zdashcode (display pkg_name) ++ (case componentNameString cname of - Just cname_str -> "-z-" ++ zdashcode cname_str + Just cname_u -> "-z-" ++ zdashcode cname_str + where cname_str = unUnqualComponentName cname_u Nothing -> "") zdashcode :: String -> String diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index 188f0f0f329..79ae454ad4a 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -18,7 +18,9 @@ module Distribution.Package ( -- * Package ids + UnqualComponentName, unUnqualComponentName, mkUnqualComponentName, PackageName, unPackageName, mkPackageName, + packageNameToUnqualComponentName, unqualComponentNameToPackageName, PackageIdentifier(..), PackageId, @@ -69,6 +71,54 @@ import Distribution.ModuleName import Text.PrettyPrint ((<+>), text) +-- | An unqualified component name, for any kind of component. +-- +-- This is distinguished from a 'ComponentName' and 'ComponentId'. The former +-- also states which of a library, executable, etc the name refers too. The +-- later uniquely identifiers a component and its closure. +-- +-- @since 2.0 +newtype UnqualComponentName = UnqualComponentName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, + Semigroup, Monoid) -- TODO: bad enabler of bad monoids + +-- | Convert 'UnqualComponentName' to 'String' +-- +-- @since 2.0 +unUnqualComponentName :: UnqualComponentName -> String +unUnqualComponentName (UnqualComponentName s) = fromShortText s + +-- | Construct a 'UnqualComponentName' from a 'String' +-- +-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'UnqualComponentName' is valid +-- +-- @since 2.0 +mkUnqualComponentName :: String -> UnqualComponentName +mkUnqualComponentName = UnqualComponentName . toShortText + +instance Binary UnqualComponentName + +parsePackageName :: Parse.ReadP r String +parsePackageName = do + ns <- Parse.sepBy1 component (Parse.char '-') + return $ intercalate "-" ns + where + component = do + cs <- Parse.munch1 isAlphaNum + if all isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +instance Text UnqualComponentName where + disp = Disp.text . unUnqualComponentName + parse = mkUnqualComponentName <$> parsePackageName + +instance NFData UnqualComponentName where + rnf (UnqualComponentName pkg) = rnf pkg + -- | A package name. -- -- Use 'mkPackageName' and 'unPackageName' to convert from/to a @@ -95,19 +145,32 @@ unPackageName (PackageName s) = fromShortText s mkPackageName :: String -> PackageName mkPackageName = PackageName . toShortText +-- | Converts a package name to an unqualified component name +-- +-- Useful in legacy situations where a package name may refer to an internal +-- component, if one is defined with that name. +-- +-- @since 2.0 +packageNameToUnqualComponentName :: PackageName -> UnqualComponentName +packageNameToUnqualComponentName (PackageName s) = UnqualComponentName s + +-- | Converts an unqualified component name to a package name +-- +-- `packageNameToUnqualComponentName` is the inverse of +-- `unqualComponentNameToPackageName`. +-- +-- Useful in legacy situations where a package name may refer to an internal +-- component, if one is defined with that name. +-- +-- @since 2.0 +unqualComponentNameToPackageName :: UnqualComponentName -> PackageName +unqualComponentNameToPackageName (UnqualComponentName s) = PackageName s + instance Binary PackageName instance Text PackageName where disp = Disp.text . unPackageName - parse = do - ns <- Parse.sepBy1 component (Parse.char '-') - return (mkPackageName (intercalate "-" ns)) - where - component = do - cs <- Parse.munch1 isAlphaNum - if all isDigit cs then Parse.pfail else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). + parse = mkPackageName <$> parsePackageName instance NFData PackageName where rnf (PackageName pkg) = rnf pkg diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index bda8f89b032..f1e029689f4 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -185,13 +185,15 @@ checkSanity pkg = ++ "Only the non-internal library can have the same name as the package." , check (not (null duplicateNames)) $ - PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames + PackageBuildImpossible $ "Duplicate sections: " + ++ commaSep (map unUnqualComponentName duplicateNames) ++ ". The name of every library, executable, test suite," ++ " and benchmark section in" ++ " the package must be unique." -- NB: but it's OK for executables to have the same name! - , check (any (== display (packageName pkg)) subLibNames) $ + -- TODO shouldn't need to compare on the string level + , check (any (== display (packageName pkg)) (display <$> subLibNames)) $ PackageBuildImpossible $ "Illegal internal library name " ++ display (packageName pkg) ++ ". Internal libraries cannot have the same name as the package." @@ -239,7 +241,7 @@ checkLibrary pkg lib = PackageDistSuspiciousWarn $ "Library " ++ (case libName lib of Nothing -> "" - Just n -> n + Just n -> display n ) ++ "does not expose any modules" -- check use of signatures sections @@ -273,7 +275,7 @@ checkExecutable pkg exe = check (null (modulePath exe)) $ PackageBuildImpossible $ - "No 'main-is' field found for executable " ++ exeName exe + "No 'main-is' field found for executable " ++ display (exeName exe) , check (not (null (modulePath exe)) && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ @@ -291,14 +293,14 @@ checkExecutable pkg exe = , check (not (null moduleDuplicates)) $ PackageBuildImpossible $ - "Duplicate modules in executable '" ++ exeName exe ++ "': " + "Duplicate modules in executable '" ++ display (exeName exe) ++ "': " ++ commaSep (map display moduleDuplicates) -- check that all autogen-modules appear on other-modules , check (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ PackageBuildImpossible $ - "On executable '" ++ exeName exe ++ "' an 'autogen-module' is not " + "On executable '" ++ display (exeName exe) ++ "' an 'autogen-module' is not " ++ "on 'other-modules'" ] @@ -325,7 +327,7 @@ checkTestSuite pkg test = , check (not $ null moduleDuplicates) $ PackageBuildImpossible $ - "Duplicate modules in test suite '" ++ testName test ++ "': " + "Duplicate modules in test suite '" ++ display (testName test) ++ "': " ++ commaSep (map display moduleDuplicates) , check mainIsWrongExt $ @@ -346,7 +348,7 @@ checkTestSuite pkg test = (testModulesAutogen test) ) $ PackageBuildImpossible $ - "On test suite '" ++ testName test ++ "' an 'autogen-module' is not " + "On test suite '" ++ display (testName test) ++ "' an 'autogen-module' is not " ++ "on 'other-modules'" ] where @@ -380,7 +382,7 @@ checkBenchmark _pkg bm = , check (not $ null moduleDuplicates) $ PackageBuildImpossible $ - "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': " + "Duplicate modules in benchmark '" ++ display (benchmarkName bm) ++ "': " ++ commaSep (map display moduleDuplicates) , check mainIsWrongExt $ @@ -395,7 +397,7 @@ checkBenchmark _pkg bm = (benchmarkModulesAutogen bm) ) $ PackageBuildImpossible $ - "On benchmark '" ++ benchmarkName bm ++ "' an 'autogen-module' is " + "On benchmark '" ++ display (benchmarkName bm) ++ "' an 'autogen-module' is " ++ "not on 'other-modules'" ] where @@ -552,7 +554,7 @@ checkFields pkg = , isNoVersion vr ] internalLibraries = - map (maybe (packageName pkg) mkPackageName . libName) + map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libName) (allLibraries pkg) buildDependsRangeOnInternalLibrary = [ dep diff --git a/Cabal/Distribution/PackageDescription/Configuration.hs b/Cabal/Distribution/PackageDescription/Configuration.hs index 56449734cc8..339d0ce5f4a 100644 --- a/Cabal/Distribution/PackageDescription/Configuration.hs +++ b/Cabal/Distribution/PackageDescription/Configuration.hs @@ -452,7 +452,7 @@ constrainBy left extra = -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go. -flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Component)]) +flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where untag (_, Lib _) (Just _, _) = userBug "Only one library expected" @@ -464,7 +464,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets } untag (deps, SubComp n c) (mb_lib, comps) | any ((== n) . fst) comps = - userBug $ "There exist several components with the same name: '" ++ n ++ "'" + userBug $ "There exist several components with the same name: '" ++ unUnqualComponentName n ++ "'" | otherwise = (mb_lib, (n, c') : comps) where @@ -484,7 +484,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets -- data PDTagged = Lib Library - | SubComp String Component + | SubComp UnqualComponentName Component | PDNull deriving Show diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 0893ff6e655..b69468f9e21 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -889,11 +889,11 @@ parsePackageDescription file = do -> PM ([SourceRepo], [Flag] ,Maybe SetupBuildInfo ,(Maybe (CondTree ConfVar [Dependency] Library)) - ,[(String, CondTree ConfVar [Dependency] Library)] - ,[(String, CondTree ConfVar [Dependency] ForeignLib)] - ,[(String, CondTree ConfVar [Dependency] Executable)] - ,[(String, CondTree ConfVar [Dependency] TestSuite)] - ,[(String, CondTree ConfVar [Dependency] Benchmark)]) + ,[(UnqualComponentName, CondTree ConfVar [Dependency] Library)] + ,[(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] + ,[(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] + ,[(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] + ,[(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]) getBody pkg = peekField >>= \mf -> case mf of Just (Section line_no sec_type sec_label sec_fields) | sec_type == "executable" -> do @@ -903,7 +903,7 @@ parsePackageDescription file = do flds <- collectFields parseExeFields sec_fields skipField (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg - return (repos, flags, csetup, mlib, sub_libs, flibs, (exename, flds): exes, tests, bms) + return (repos, flags, csetup, mlib, sub_libs, flibs, (mkUnqualComponentName exename, flds): exes, tests, bms) | sec_type == "foreign-library" -> do when (null sec_label) $ lift $ syntaxError line_no @@ -922,7 +922,7 @@ parsePackageDescription file = do then do skipField (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg - return (repos, flags, csetup, mlib, sub_libs, (libname, flds):flibs, exes, tests, bms) + return (repos, flags, csetup, mlib, sub_libs, (mkUnqualComponentName libname, flds):flibs, exes, tests, bms) else lift $ syntaxError line_no $ "Foreign library \"" ++ libname ++ "\" is missing required field \"type\" or the field " @@ -948,7 +948,7 @@ parsePackageDescription file = do skipField (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg return (repos, flags, csetup, mlib, sub_libs, flibs, exes, - (testname, flds) : tests, bms) + (mkUnqualComponentName testname, flds) : tests, bms) else lift $ syntaxError line_no $ "Test suite \"" ++ testname ++ "\" is missing required field \"type\" or the field " @@ -974,7 +974,7 @@ parsePackageDescription file = do skipField (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg return (repos, flags, csetup, mlib, sub_libs, flibs, exes, - tests, (benchname, flds) : bms) + tests, (mkUnqualComponentName benchname, flds) : bms) else lift $ syntaxError line_no $ "Benchmark \"" ++ benchname ++ "\" is missing required field \"type\" or the field " @@ -994,7 +994,7 @@ parsePackageDescription file = do (repos, flags, csetup, mlib, sub_libs, flibs, exes, tests, bms) <- getBody pkg case mb_libname of Just libname -> - return (repos, flags, csetup, mlib, (libname, flds) : sub_libs, flibs, exes, tests, bms) + return (repos, flags, csetup, mlib, (mkUnqualComponentName libname, flds) : sub_libs, flibs, exes, tests, bms) Nothing -> do when (isJust mlib) $ lift $ syntaxError line_no "There can only be one (public) library section in a package description." @@ -1141,9 +1141,9 @@ parsePackageDescription file = do checkForUndefinedFlags :: [Flag] -> Maybe (CondTree ConfVar [Dependency] Library) -> - [(String, CondTree ConfVar [Dependency] Library)] -> - [(String, CondTree ConfVar [Dependency] Executable)] -> - [(String, CondTree ConfVar [Dependency] TestSuite)] -> + [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> + [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> + [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> PM () checkForUndefinedFlags flags mlib sub_libs exes tests = do let definedFlags = map flagName flags @@ -1252,11 +1252,11 @@ parseHookedBuildInfo inp = do | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) parseLib _ = return Nothing - parseExe :: [Field] -> ParseResult (String, BuildInfo) + parseExe :: [Field] -> ParseResult (UnqualComponentName, BuildInfo) parseExe (F line inFieldName mName:bi) | lowercase inFieldName == "executable" = do bis <- parseBI bi - return (mName, bis) + return (mkUnqualComponentName mName, bis) | otherwise = syntaxError line "expecting 'executable' at top of stanza" parseExe (_:_) = cabalBug "`parseExe' called on a non-field" parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/Cabal/Distribution/PackageDescription/Parsec.hs index 0bff3b36301..cdc7895863a 100644 --- a/Cabal/Distribution/PackageDescription/Parsec.hs +++ b/Cabal/Distribution/PackageDescription/Parsec.hs @@ -34,6 +34,7 @@ import qualified Data.ByteString as BS import Data.List (partition) import qualified Data.Map as Map import qualified Distribution.Compat.SnocList as SnocList +import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Parsec.FieldDescr import Distribution.Parsec.Class (parsec) @@ -215,21 +216,21 @@ parseGenericPackageDescription' lexWarnings fs = do -- Sublibraries | name == "library" = do - name' <- parseName pos args + name' <- parseUnqualComponentName pos args lib <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields -- TODO check duplicate name here? let gpd' = gpd { condSubLibraries = condSubLibraries gpd ++ [(name', lib)] } pure gpd' | name == "foreign-library" = do - name' <- parseName pos args + name' <- parseUnqualComponentName pos args flib <- parseCondTree foreignLibFieldDescrs storeXFieldsForeignLib (targetBuildDepends . foreignLibBuildInfo) emptyForeignLib fields -- TODO check duplicate name here? let gpd' = gpd { condForeignLibs = condForeignLibs gpd ++ [(name', flib)] } pure gpd' | name == "executable" = do - name' <- parseName pos args + name' <- parseUnqualComponentName pos args -- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010 exe <- parseCondTree (tail executableFieldDescrs) storeXFieldsExe (targetBuildDepends . buildInfo) emptyExecutable fields -- TODO check duplicate name here? @@ -237,7 +238,7 @@ parseGenericPackageDescription' lexWarnings fs = do pure gpd' | name == "test-suite" = do - name' <- parseName pos args + name' <- parseUnqualComponentName pos args testStanza <- parseCondTree testSuiteFieldDescrs storeXFieldsTest (targetBuildDepends . testStanzaBuildInfo) emptyTestStanza fields testSuite <- traverse (validateTestSuite pos) testStanza -- TODO check duplicate name here? @@ -245,7 +246,7 @@ parseGenericPackageDescription' lexWarnings fs = do pure gpd' | name == "benchmark" = do - name' <- parseName pos args + name' <- parseUnqualComponentName pos args benchStanza <- parseCondTree benchmarkFieldDescrs storeXFieldsBenchmark (targetBuildDepends . benchmarkStanzaBuildInfo) emptyBenchmarkStanza fields bench <- traverse (validateBenchmark pos) benchStanza -- TODO check duplicate name here? @@ -363,6 +364,10 @@ parseName pos args = case args of parseFailure pos $ "Invalid name " ++ show args pure "" +parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName +parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args + + -- | Parse a non-recursive list of fields, given a list of field descriptions, -- a structure to accumulate the parsed fields, and a function -- that can decide what to do with fields which don't match any diff --git a/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs b/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs index 755d2503466..0c983efc307 100644 --- a/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs +++ b/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs @@ -231,7 +231,7 @@ executableFieldDescrs = [ -- note ordering: configuration must come first, for -- showPackageDescription. simpleField "executable" - showToken parsecToken + disp parsec exeName (\xs exe -> exe{exeName=xs}) , simpleField "main-is" showFilePath parsecFilePath diff --git a/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/Cabal/Distribution/PackageDescription/PrettyPrint.hs index 8caa0105a2d..7c9914e5f73 100644 --- a/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -126,11 +126,10 @@ ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc ppCondLibrary Nothing = mempty ppCondLibrary (Just condTree) = emptyLine $ text "library" - $+$ nest indentWith (ppCondTree condTree Nothing ppLib) - -ppCondSubLibraries :: [(String, CondTree ConfVar [Dependency] Library)] -> Doc + $+$ nest indentWith (ppCondTree condTree Nothing ppLib) +ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc ppCondSubLibraries libs = - vcat [emptyLine $ text ("library " ++ n) + vcat [emptyLine $ (text "library " <+> disp n) $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs] ppLib :: Library -> Maybe Library -> Doc @@ -139,9 +138,9 @@ ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) -ppCondExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc ppCondExecutables exes = - vcat [emptyLine $ text ("executable " ++ n) + vcat [emptyLine $ (text "executable " <+> disp n) $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] where ppExe (Executable _ modulePath' buildInfo') Nothing = @@ -155,9 +154,9 @@ ppCondExecutables exes = $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 $+$ ppCustomFields (customFieldsBI buildInfo') -ppCondTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc ppCondTestSuites suites = - emptyLine $ vcat [ text ("test-suite " ++ n) + emptyLine $ vcat [ (text "test-suite " <+> disp n) $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) | (n,condTree) <- suites] where @@ -187,9 +186,9 @@ ppCondTestSuites suites = TestSuiteLibV09 _ m -> Just m _ -> Nothing -ppCondBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc +ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc ppCondBenchmarks suites = - emptyLine $ vcat [ text ("benchmark " ++ n) + emptyLine $ vcat [ (text "benchmark " <+> disp n) $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark) | (n,condTree) <- suites] where @@ -299,25 +298,25 @@ ppMaybeLibrary (Just lib) = ppSubLibraries :: [Library] -> Doc ppSubLibraries libs = vcat [ - emptyLine $ text "library" <+> text libname + emptyLine $ text "library" <+> disp libname $+$ nest indentWith (ppFields libFieldDescrs lib) | lib@Library{ libName = Just libname } <- libs ] ppForeignLibs :: [ForeignLib] -> Doc ppForeignLibs flibs = vcat [ - emptyLine $ text "foreign library" <+> text flibname + emptyLine $ text "foreign library" <+> disp flibname $+$ nest indentWith (ppFields foreignLibFieldDescrs flib) | flib@ForeignLib{ foreignLibName = flibname } <- flibs ] ppExecutables :: [Executable] -> Doc ppExecutables exes = vcat [ - emptyLine $ text "executable" <+> text (exeName exe) + emptyLine $ text "executable" <+> disp (exeName exe) $+$ nest indentWith (ppFields executableFieldDescrs exe) | exe <- exes ] ppTestSuites :: [TestSuite] -> Doc ppTestSuites tests = vcat [ - emptyLine $ text "test-suite" <+> text (testName test) + emptyLine $ text "test-suite" <+> disp (testName test) $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza) | test <- tests , let test_stanza @@ -346,7 +345,7 @@ testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing ppBenchmarks :: [Benchmark] -> Doc ppBenchmarks benchs = vcat [ - emptyLine $ text "benchmark" <+> text (benchmarkName bench) + emptyLine $ text "benchmark" <+> disp (benchmarkName bench) $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza) | bench <- benchs , let bench_stanza = BenchmarkStanza { @@ -377,7 +376,7 @@ showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ Nothing -> mempty Just bi -> ppBuildInfo bi) $$ vcat [ space - $$ text "executable:" <+> text name + $$ (text "executable:" <+> disp name) $$ ppBuildInfo bi | (name, bi) <- ex_bis ] where diff --git a/Cabal/Distribution/Parsec/Class.hs b/Cabal/Distribution/Parsec/Class.hs index 179ee0fa2a1..f7b7b6946b4 100644 --- a/Cabal/Distribution/Parsec/Class.hs +++ b/Cabal/Distribution/Parsec/Class.hs @@ -34,7 +34,9 @@ import Distribution.License (License (..)) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Package - (Dependency (..), PackageName, mkPackageName) + (Dependency (..), + UnqualComponentName, mkUnqualComponentName, + PackageName, mkPackageName) import Distribution.System (Arch (..), ClassificationStrictness (..), OS (..), classifyArch, classifyOS) @@ -86,14 +88,22 @@ parsecWarning t w = -- TODO: use lexemeParsec +-- TODO avoid String +parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String +parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') + where + component :: P.Stream s Identity Char => P.Parsec s [PWarning] String + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs + then fail "all digits in portion of unqualified component name" + else return cs + +instance Parsec UnqualComponentName where + parsec = mkUnqualComponentName <$> parsecUnqualComponentName + instance Parsec PackageName where - -- todo - parsec = mkPackageName . intercalate "-" <$> P.sepBy1 component (P.char '-') - where - component :: P.Stream s Identity Char => P.Parsec s [PWarning] String - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits PackageName" else return cs + parsec = mkPackageName <$> parsecUnqualComponentName instance Parsec ModuleName where parsec = ModuleName.fromComponents <$> P.sepBy1 component (P.char '.') diff --git a/Cabal/Distribution/Simple/Bench.hs b/Cabal/Distribution/Simple/Bench.hs index 1bd565343f3..2f8021be19b 100644 --- a/Cabal/Distribution/Simple/Bench.hs +++ b/Cabal/Distribution/Simple/Bench.hs @@ -21,6 +21,7 @@ module Distribution.Simple.Bench import Prelude () import Distribution.Compat.Prelude +import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler @@ -52,11 +53,9 @@ bench args pkg_descr lbi flags = do doBench bm = case PD.benchmarkInterface bm of PD.BenchmarkExeV10 _ _ -> do - let cmd = LBI.buildDir lbi PD.benchmarkName bm - PD.benchmarkName bm <.> exeExtension + let cmd = LBI.buildDir lbi name name <.> exeExtension options = map (benchOption pkg_descr lbi bm) $ benchmarkOptions flags - name = PD.benchmarkName bm -- Check that the benchmark executable exists. exists <- doesFileExist cmd unless exists $ die $ @@ -72,9 +71,10 @@ bench args pkg_descr lbi flags = do _ -> do notice verbosity $ "No support for running " - ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: " - ++ show (disp $ PD.benchmarkType bm) + ++ "benchmark " ++ name ++ " of type: " + ++ display (PD.benchmarkType bm) exitFailure + where name = unUnqualComponentName $ PD.benchmarkName bm unless (PD.hasBenchmarks pkg_descr) $ do notice verbosity "Package has no benchmarks." @@ -90,9 +90,9 @@ bench args pkg_descr lbi flags = do let benchmarkMap = zip enabledNames enabledBenchmarks enabledNames = map PD.benchmarkName enabledBenchmarks allNames = map PD.benchmarkName pkgBenchmarks - in case lookup bmName benchmarkMap of + in case lookup (mkUnqualComponentName bmName) benchmarkMap of Just t -> return t - _ | bmName `elem` allNames -> + _ | mkUnqualComponentName bmName `elem` allNames -> die $ "Package configured with benchmark " ++ bmName ++ " disabled." | otherwise -> die $ "no such benchmark: " ++ bmName @@ -123,4 +123,4 @@ benchOption pkg_descr lbi bm template = env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)] + [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 7916c35f59a..ecda3c6888d 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -192,7 +192,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes extras <- preprocessExtras comp lbi case libName lib of Nothing -> info verbosity $ "Building library..." - Just n -> info verbosity $ "Building library " ++ n ++ "..." + Just n -> info verbosity $ "Building library " ++ display n ++ "..." let libbi = libBuildInfo lib lib' = lib { libBuildInfo = addExtraCSources libbi extras } buildLib verbosity numJobs pkg_descr lbi lib' clbi @@ -220,7 +220,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CFLib flib) clbi _distPref = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - info verbosity $ "Building foreign library " ++ foreignLibName flib ++ "..." + info verbosity $ "Building foreign library " ++ display (foreignLibName flib) ++ "..." buildFLib verbosity numJobs pkg_descr lbi flib clbi return Nothing @@ -228,7 +228,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras comp lbi - info verbosity $ "Building executable " ++ exeName exe ++ "..." + info verbosity $ "Building executable " ++ display (exeName exe) ++ "..." let ebi = buildInfo exe exe' = exe { buildInfo = addExtraCSources ebi extras } buildExe verbosity numJobs pkg_descr lbi exe' clbi @@ -241,7 +241,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras comp lbi - info verbosity $ "Building test suite " ++ testName test ++ "..." + info verbosity $ "Building test suite " ++ display (testName test) ++ "..." let ebi = buildInfo exe exe' = exe { buildInfo = addExtraCSources ebi extras } buildExe verbosity numJobs pkg_descr lbi exe' clbi @@ -262,7 +262,7 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras comp lbi - info verbosity $ "Building test suite " ++ testName test ++ "..." + info verbosity $ "Building test suite " ++ display (testName test) ++ "..." buildLib verbosity numJobs pkg lbi lib libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still @@ -287,7 +287,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes extras <- preprocessExtras comp lbi - info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..." + info verbosity $ "Building benchmark " ++ display (benchmarkName bm) ++ "..." let ebi = buildInfo exe exe' = exe { buildInfo = addExtraCSources ebi extras } buildExe verbosity numJobs pkg_descr lbi exe' exeClbi @@ -458,7 +458,7 @@ testSuiteLibV09AsLibAndExe pkg_descr stubName test ++ "-tmp" testLibDep = thisPackageVersion $ package pkg exe = Executable { - exeName = stubName test, + exeName = mkUnqualComponentName $ stubName test, modulePath = stubFilePath test, buildInfo = (testBuildInfo test) { hsSourceDirs = [ testDir ], @@ -479,7 +479,7 @@ testSuiteLibV09AsLibAndExe pkg_descr componentComponentId = mkComponentId (stubName test), componentInternalDeps = [componentUnitId clbi], componentExeDeps = [], - componentLocalName = CExeName (stubName test), + componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, componentPackageDeps = deps, -- Assert DefUnitId invariant! -- Executable can't be indefinite, so dependencies must @@ -535,7 +535,7 @@ addInternalBuildTools pkg lbi bi progs = | toolName <- toolNames , let toolLocation = buildDir lbi toolName toolName <.> exeExtension ] toolNames = intersect buildToolNames internalExeNames - internalExeNames = map exeName (executables pkg) + internalExeNames = map (unUnqualComponentName . exeName) (executables pkg) buildToolNames = map buildToolName (buildTools bi) where buildToolName (Dependency pname _ ) = unPackageName pname diff --git a/Cabal/Distribution/Simple/BuildTarget.hs b/Cabal/Distribution/Simple/BuildTarget.hs index 46a556ff3b5..6d1a0408bd1 100644 --- a/Cabal/Distribution/Simple/BuildTarget.hs +++ b/Cabal/Distribution/Simple/BuildTarget.hs @@ -474,11 +474,11 @@ pkgComponentInfo pkg = componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName componentStringName pkg CLibName = display (packageName pkg) -componentStringName _ (CSubLibName name) = name -componentStringName _ (CFLibName name) = name -componentStringName _ (CExeName name) = name -componentStringName _ (CTestName name) = name -componentStringName _ (CBenchName name) = name +componentStringName _ (CSubLibName name) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name componentModules :: Component -> [ModuleName] -- TODO: Use of 'explicitLibModules' here is a bit wrong: diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 447b58d06cc..8aa4e9ec028 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -563,7 +563,7 @@ configure (pkg_descr0', pbi) cfg = do -- TODO: Factor this into a helper package. let requiredBuildTools = [ buildTool - | let exeNames = map exeName (executables pkg_descr) + | let exeNames = map (unUnqualComponentName . exeName) (executables pkg_descr) , bi <- enabledBuildInfos pkg_descr enabled , buildTool@(Dependency toolPName reqVer) <- buildTools bi @@ -813,7 +813,7 @@ getInternalPackages pkg_descr0 = let pkg_descr = flattenPackageDescription pkg_descr0 f lib = case libName lib of Nothing -> (packageName pkg_descr, CLibName) - Just n' -> (mkPackageName n', CSubLibName n') + Just n' -> (unqualComponentNameToPackageName n', CSubLibName n') in Map.fromList (map f (allLibraries pkg_descr)) -- | Returns true if a dependency is satisfiable. This function diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index efee00a6e86..3f846d3b84b 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -835,10 +835,10 @@ gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib gbuildInfo (GReplFLib flib) = foreignLibBuildInfo flib gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = exeName exe -gbuildName (GReplExe exe) = exeName exe -gbuildName (GBuildFLib flib) = foreignLibName flib -gbuildName (GReplFLib flib) = foreignLibName flib +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib flib) = unUnqualComponentName $ foreignLibName flib gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String gbuildTargetName _lbi (GBuildExe exe) = exeTargetName exe @@ -847,7 +847,7 @@ gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib gbuildTargetName lbi (GReplFLib flib) = flibTargetName lbi flib exeTargetName :: Executable -> String -exeTargetName exe = exeName exe `withExt` exeExtension +exeTargetName exe = unUnqualComponentName (exeName exe) `withExt` exeExtension -- | Target name for a foreign library (the actual file name) -- @@ -868,7 +868,7 @@ flibTargetName lbi flib = (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" where nm :: String - nm = foreignLibName flib + nm = unUnqualComponentName $ foreignLibName flib platformOS :: Platform -> OS platformOS (Platform _arch os) = os @@ -945,7 +945,6 @@ gbuild verbosity numJobs _pkg_descr lbi bm clbi = do let targetName = gbuildTargetName lbi bm let targetDir = buildDir lbi (gbuildName bm) let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True tmpDir @@ -1415,11 +1414,12 @@ installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir - let exeFileName = exeTargetName exe - fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeTargetName exe + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix installBinary dest = do installExecutableFile verbosity - (buildPref exeName exe exeFileName) + (buildPref exeName' exeFileName) (dest <.> exeExtension) when (stripExes lbi) $ Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs index a71bcfb7a7a..6d8f1dbc827 100644 --- a/Cabal/Distribution/Simple/GHCJS.hs +++ b/Cabal/Distribution/Simple/GHCJS.hs @@ -521,14 +521,15 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi runGhcjsProg = runGHC verbosity ghcjsProg comp platform exeBi = buildInfo exe + let exeName'' = unUnqualComponentName exeName' -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' <.> - (if takeExtension exeName' /= ('.':exeExtension) + let exeNameReal = exeName'' <.> + (if takeExtension exeName'' /= ('.':exeExtension) then exeExtension else "") - let targetDir = (buildDir lbi) exeName' - let exeDir = targetDir (exeName' ++ "-tmp") + let targetDir = (buildDir lbi) exeName'' + let exeDir = targetDir (exeName'' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir -- TODO: do we need to put hs-boot files into place for mutually recursive @@ -539,7 +540,7 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi let isCoverageEnabled = exeCoverage lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'' | otherwise = mempty -- build executables @@ -755,12 +756,13 @@ installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir - let exeFileName = exeName exe - fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeName' + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix installBinary dest = do runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ [ "--install-executable" - , buildPref exeName exe exeFileName + , buildPref exeName' exeFileName , "-o", dest ] ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index 2df6e1ab3ee..09a43580424 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -359,8 +359,8 @@ fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (buildInfo exe) return args { - argOutputDir = Dir (exeName exe), - argTitle = Flag (exeName exe) + argOutputDir = Dir $ unUnqualComponentName $ exeName exe, + argTitle = Flag $ unUnqualComponentName $ exeName exe } fromForeignLib :: Verbosity @@ -376,8 +376,8 @@ fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (foreignLibBuildInfo flib) return args { - argOutputDir = Dir (foreignLibName flib), - argTitle = Flag (foreignLibName flib) + argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib, + argTitle = Flag $ unUnqualComponentName $ foreignLibName flib } compToExe :: Component -> Maybe Executable @@ -687,7 +687,7 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = doExe com = case (compToExe com) of Just exe -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr - exeName exe "src" + unUnqualComponentName (exeName exe) "src" runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe clbi Nothing -> do warn (fromFlag $ hscolourVerbosity flags) @@ -699,7 +699,7 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib clbi CFLib flib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr - foreignLibName flib "src" + unUnqualComponentName (foreignLibName flib) "src" runHsColour hscolourProg outputDir =<< getFLibSourceFiles lbi flib clbi CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp @@ -793,13 +793,13 @@ getSourceFiles dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ exeBuildDir :: LocalBuildInfo -> Executable -> FilePath exeBuildDir lbi exe = buildDir lbi nm nm ++ "-tmp" where - nm = exeName exe + nm = unUnqualComponentName $ exeName exe -- | The directory where we put build results for a foreign library flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath flibBuildDir lbi flib = buildDir lbi nm nm ++ "-tmp" where - nm = foreignLibName flib + nm = unUnqualComponentName $ foreignLibName flib -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. diff --git a/Cabal/Distribution/Simple/Hpc.hs b/Cabal/Distribution/Simple/Hpc.hs index f1ae33390dc..b897c925ac2 100644 --- a/Cabal/Distribution/Simple/Hpc.hs +++ b/Cabal/Distribution/Simple/Hpc.hs @@ -28,6 +28,7 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.ModuleName ( main ) +import Distribution.Package import Distribution.PackageDescription ( TestSuite(..) , testModules @@ -101,22 +102,23 @@ markupTest :: Verbosity -> TestSuite -> IO () markupTest verbosity lbi distPref libName suite = do - tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName suite + tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' when tixFileExists $ do -- behaviour of 'markup' depends on version, so we need *a* version -- but no particular one (hpc, hpcVer, _) <- requireProgramVersion verbosity hpcProgram anyVersion (withPrograms lbi) - let htmlDir_ = htmlDir distPref way $ testName suite + let htmlDir_ = htmlDir distPref way testName' markup hpc hpcVer verbosity - (tixFilePath distPref way $ testName suite) mixDirs + (tixFilePath distPref way testName') mixDirs htmlDir_ (testModules suite ++ [ main ]) notice verbosity $ "Test coverage report written to " ++ htmlDir_ "hpc_index" <.> "html" where way = guessWay lbi - mixDirs = map (mixDir distPref way) [ testName suite, libName ] + testName' = unUnqualComponentName $ testName suite + mixDirs = map (mixDir distPref way) [ testName', libName ] -- | Generate the HTML markup for all of a package's test suites. markupPackage :: Verbosity @@ -126,7 +128,7 @@ markupPackage :: Verbosity -> [TestSuite] -> IO () markupPackage verbosity lbi distPref libName suites = do - let tixFiles = map (tixFilePath distPref way . testName) suites + let tixFiles = map (tixFilePath distPref way) testNames tixFilesExist <- traverse doesFileExist tixFiles when (and tixFilesExist) $ do -- behaviour of 'markup' depends on version, so we need *a* version @@ -143,4 +145,5 @@ markupPackage verbosity lbi distPref libName suites = do ++ htmlDir' "hpc_index.html" where way = guessWay lbi - mixDirs = map (mixDir distPref way) $ libName : map testName suites + testNames = fmap (unUnqualComponentName . testName) suites + mixDirs = map (mixDir distPref way) $ libName : testNames diff --git a/Cabal/Distribution/Simple/Install.hs b/Cabal/Distribution/Simple/Install.hs index b693bd47294..29fdcdb0727 100644 --- a/Cabal/Distribution/Simple/Install.hs +++ b/Cabal/Distribution/Simple/Install.hs @@ -165,7 +165,7 @@ copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do case libName lib of Nothing -> notice verbosity ("Installing library in " ++ libPref) - Just n -> notice verbosity ("Installing internal library " ++ n ++ " in " ++ libPref) + Just n -> notice verbosity ("Installing internal library " ++ display n ++ " in " ++ libPref) -- install include files for all compilers - they may be needed to compile -- haskell files (using the CPP extension) @@ -189,7 +189,7 @@ copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest buildPref = componentBuildDir lbi clbi - notice verbosity ("Installing foreign library " ++ foreignLibName flib ++ " in " ++ flibPref) + notice verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) case compilerFlavor (compiler lbi) of GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib @@ -207,7 +207,7 @@ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do uid = componentUnitId clbi progPrefixPref = substPathTemplate (packageId pkg_descr) lbi uid (progPrefix lbi) progSuffixPref = substPathTemplate (packageId pkg_descr) lbi uid (progSuffix lbi) - notice verbosity ("Installing executable " ++ exeName exe ++ " in " ++ binPref) + notice verbosity ("Installing executable " ++ display (exeName exe) ++ " in " ++ binPref) inPath <- isInSearchPath binPref when (not inPath) $ warn verbosity ("The directory " ++ binPref diff --git a/Cabal/Distribution/Simple/JHC.hs b/Cabal/Distribution/Simple/JHC.hs index 61daa441283..04cb5eed653 100644 --- a/Cabal/Distribution/Simple/JHC.hs +++ b/Cabal/Distribution/Simple/JHC.hs @@ -134,7 +134,7 @@ buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo buildExe verbosity _pkg_descr lbi exe clbi = do let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) let exeBi = buildInfo exe - let out = buildDir lbi exeName exe + let out = buildDir lbi display (exeName exe) let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity runProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) @@ -185,7 +185,7 @@ installLib verb _lbi dest _dyn_dest build_dir pkg_descr _lib _clbi = do installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () installExe verb dest build_dir (progprefix,progsuffix) _ exe = do - let exe_name = exeName exe + let exe_name = display $ exeName exe src = exe_name exeExtension out = (progprefix ++ exe_name ++ progsuffix) exeExtension createDirectoryIfMissingVerbose verb True dest diff --git a/Cabal/Distribution/Simple/LHC.hs b/Cabal/Distribution/Simple/LHC.hs index bb57deaea81..8c36de613d3 100644 --- a/Cabal/Distribution/Simple/LHC.hs +++ b/Cabal/Distribution/Simple/LHC.hs @@ -459,6 +459,7 @@ buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let exeName'' = unUnqualComponentName exeName' let pref = buildDir lbi runGhcProg = runDbProgram verbosity lhcProgram (withPrograms lbi) @@ -466,11 +467,11 @@ buildExe verbosity _pkg_descr lbi (compiler lbi) (withProfExe lbi) (buildInfo exe) -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' <.> - (if null $ takeExtension exeName' then exeExtension else "") + let exeNameReal = exeName'' <.> + (if null $ takeExtension exeName'' then exeExtension else "") - let targetDir = pref exeName' - let exeDir = targetDir (exeName' ++ "-tmp") + let targetDir = pref exeName'' + let exeDir = targetDir (exeName'' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir -- TODO: do we need to put hs-boot files into place for mutually recursive modules? @@ -675,11 +676,11 @@ installExe :: Verbosity installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir - let exeFileName = exeName exe <.> exeExtension - fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + let exeFileName = unUnqualComponentName (exeName exe) <.> exeExtension + fixedExeBaseName = progprefix ++ unUnqualComponentName (exeName exe) ++ progsuffix installBinary dest = do installExecutableFile verbosity - (buildPref exeName exe exeFileName) + (buildPref unUnqualComponentName (exeName exe) exeFileName) (dest <.> exeExtension) stripExe verbosity lbi exeFileName (dest <.> exeExtension) installBinary (binDir fixedExeBaseName) diff --git a/Cabal/Distribution/Simple/LocalBuildInfo.hs b/Cabal/Distribution/Simple/LocalBuildInfo.hs index 1893a2825ab..19595ed2a8c 100644 --- a/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ b/Cabal/Distribution/Simple/LocalBuildInfo.hs @@ -111,12 +111,12 @@ componentBuildDir lbi clbi else display (componentUnitId clbi) CSubLibName s -> if display (componentUnitId clbi) == display (componentComponentId clbi) - then s + then unUnqualComponentName s else display (componentUnitId clbi) - CFLibName s -> s - CExeName s -> s - CTestName s -> s - CBenchName s -> s + CFLibName s -> unUnqualComponentName s + CExeName s -> unUnqualComponentName s + CTestName s -> unUnqualComponentName s + CBenchName s -> unUnqualComponentName s {-# DEPRECATED getComponentLocalBuildInfo "This function is not well-defined, because a 'ComponentName' does not uniquely identify a 'ComponentLocalBuildInfo'. If you have a 'TargetInfo', you should use 'targetCLBI' to get the 'ComponentLocalBuildInfo'. Otherwise, use 'componentNameTargets' to get all possible 'ComponentLocalBuildInfo's. This will be removed in Cabal 2.2." #-} getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo diff --git a/Cabal/Distribution/Simple/PreProcess.hs b/Cabal/Distribution/Simple/PreProcess.hs index f3323471c96..16d441ec890 100644 --- a/Cabal/Distribution/Simple/PreProcess.hs +++ b/Cabal/Distribution/Simple/PreProcess.hs @@ -158,27 +158,29 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $ pre dirs (componentBuildDir lbi clbi) (localHandlers bi) (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do - let flibDir = buildDir lbi nm nm ++ "-tmp" + let nm' = unUnqualComponentName nm + flibDir = buildDir lbi nm' nm' ++ "-tmp" dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - setupMessage verbosity ("Preprocessing foreign library '" ++ nm ++ "' for") (packageId pd) + setupMessage verbosity ("Preprocessing foreign library '" ++ nm' ++ "' for") (packageId pd) for_ (map ModuleName.toFilePath $ foreignLibModules flib) $ pre dirs flibDir (localHandlers bi) (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let exeDir = buildDir lbi nm nm ++ "-tmp" + let nm' = unUnqualComponentName nm + exeDir = buildDir lbi nm' nm' ++ "-tmp" dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) + setupMessage verbosity ("Preprocessing executable '" ++ nm' ++ "' for") (packageId pd) for_ (map ModuleName.toFilePath $ otherModules bi) $ pre dirs exeDir (localHandlers bi) pre (hsSourceDirs bi) exeDir (localHandlers bi) $ dropExtensions (modulePath exe) CTest test@TestSuite{ testName = nm } -> do - setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) + let nm' = unUnqualComponentName nm + setupMessage verbosity ("Preprocessing test suite '" ++ nm' ++ "' for") (packageId pd) case testInterface test of TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi testName test - testName test ++ "-tmp" + preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" TestSuiteLibV09 _ _ -> do let testDir = buildDir lbi stubName test stubName test ++ "-tmp" @@ -187,11 +189,11 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of TestSuiteUnsupported tt -> die $ "No support for preprocessing test " ++ "suite type " ++ display tt CBench bm@Benchmark{ benchmarkName = nm } -> do - setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd) + let nm' = unUnqualComponentName nm + setupMessage verbosity ("Preprocessing benchmark '" ++ nm' ++ "' for") (packageId pd) case benchmarkInterface bm of BenchmarkExeV10 _ f -> - preProcessBench bm f $ buildDir lbi benchmarkName bm - benchmarkName bm ++ "-tmp" + preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " ++ "type " ++ display tt where @@ -655,22 +657,26 @@ preprocessExtras :: Component -> IO [FilePath] preprocessExtras comp lbi = case comp of CLib _ -> pp $ buildDir lbi - (CExe Executable { exeName = nm }) -> - pp $ buildDir lbi nm nm ++ "-tmp" - (CFLib ForeignLib { foreignLibName = nm }) -> - pp $ buildDir lbi nm nm ++ "-tmp" + (CExe Executable { exeName = nm }) -> do + let nm' = unUnqualComponentName nm + pp $ buildDir lbi nm' nm' ++ "-tmp" + (CFLib ForeignLib { foreignLibName = nm }) -> do + let nm' = unUnqualComponentName nm + pp $ buildDir lbi nm' nm' ++ "-tmp" CTest test -> do + let nm' = unUnqualComponentName $ testName test case testInterface test of TestSuiteExeV10 _ _ -> - pp $ buildDir lbi testName test testName test ++ "-tmp" + pp $ buildDir lbi nm' nm' ++ "-tmp" TestSuiteLibV09 _ _ -> pp $ buildDir lbi stubName test stubName test ++ "-tmp" TestSuiteUnsupported tt -> die $ "No support for preprocessing test " ++ "suite type " ++ display tt CBench bm -> do + let nm' = unUnqualComponentName $ benchmarkName bm case benchmarkInterface bm of BenchmarkExeV10 _ _ -> - pp $ buildDir lbi benchmarkName bm benchmarkName bm ++ "-tmp" + pp $ buildDir lbi nm' nm' ++ "-tmp" BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " ++ "type " ++ display tt where @@ -690,7 +696,7 @@ preprocessExtras comp lbi = case comp of not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ] component_dirs = component_names (localPkgDescr lbi) -- TODO: libify me - component_names pkg_descr = + component_names pkg_descr = fmap unUnqualComponentName $ mapMaybe libName (subLibraries pkg_descr) ++ map exeName (executables pkg_descr) ++ map testName (testSuites pkg_descr) ++ diff --git a/Cabal/Distribution/Simple/Test.hs b/Cabal/Distribution/Simple/Test.hs index e460af34dc9..5ad52135de0 100644 --- a/Cabal/Distribution/Simple/Test.hs +++ b/Cabal/Distribution/Simple/Test.hs @@ -21,6 +21,7 @@ module Distribution.Simple.Test import Prelude () import Distribution.Compat.Prelude +import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.Compiler import Distribution.Simple.Hpc @@ -70,7 +71,7 @@ test args pkg_descr lbi flags = do _ -> return TestSuiteLog { testSuiteName = PD.testName suite , testLogs = TestLog - { testName = PD.testName suite + { testName = unUnqualComponentName $ PD.testName suite , testOptionsReturned = [] , testResult = Error $ "No support for running test suite type: " @@ -93,9 +94,10 @@ test args pkg_descr lbi flags = do let testMap = zip enabledNames enabledTests enabledNames = map (PD.testName . fst) enabledTests allNames = map PD.testName pkgTests - in case lookup tName testMap of + tCompName = mkUnqualComponentName tName + in case lookup tCompName testMap of Just t -> return (t, Nothing) - _ | tName `elem` allNames -> + _ | tCompName `elem` allNames -> die $ "Package configured with test suite " ++ tName ++ " disabled." | otherwise -> die $ "no such test: " ++ tName diff --git a/Cabal/Distribution/Simple/Test/ExeV10.hs b/Cabal/Distribution/Simple/Test/ExeV10.hs index b3509caf7cd..b5c559ead45 100644 --- a/Cabal/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/Distribution/Simple/Test/ExeV10.hs @@ -6,6 +6,7 @@ module Distribution.Simple.Test.ExeV10 ) where import Prelude () +import Distribution.Package import Distribution.Compat.Prelude import Distribution.Compat.CreatePipe @@ -43,13 +44,13 @@ runTest :: PD.PackageDescription runTest pkg_descr lbi clbi flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi - tixDir_ = tixDir distPref way $ PD.testName suite + tixDir_ = tixDir distPref way testName' pwd <- getCurrentDirectory existingEnv <- getEnvironment - let cmd = LBI.buildDir lbi PD.testName suite - PD.testName suite <.> exeExtension + let cmd = LBI.buildDir lbi testName' + testName' <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd unless exists $ die $ "Error: Could not find test program \"" ++ cmd @@ -64,7 +65,7 @@ runTest pkg_descr lbi clbi flags suite = do createDirectoryIfMissing True tixDir_ -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ PD.testName suite + notice verbosity $ summarizeSuiteStart $ testName' (wOut, wErr, logText) <- case details of Direct -> return (stdout, stderr, "") @@ -85,7 +86,7 @@ runTest pkg_descr lbi clbi flags suite = do let opts = map (testOption pkg_descr lbi suite) (testOptions flags) dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way (PD.testName suite) + tixFile = pwd tixFilePath distPref way (testName') pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) : existingEnv shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv @@ -106,7 +107,7 @@ runTest pkg_descr lbi clbi flags suite = do let suiteLog = buildLog exit -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite + appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName' -- Append contents of temporary log file to the final human- -- readable log file @@ -132,6 +133,8 @@ runTest pkg_descr lbi clbi flags suite = do return suiteLog where + testName' = unUnqualComponentName $ PD.testName suite + distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags details = fromFlag $ testShowDetails flags @@ -141,19 +144,19 @@ runTest pkg_descr lbi clbi flags suite = do let r = case exit of ExitSuccess -> Pass ExitFailure c -> Fail $ "exit code: " ++ show c - n = PD.testName suite + --n = unUnqualComponentName $ PD.testName suite l = TestLog - { testName = n + { testName = testName' , testOptionsReturned = [] , testResult = r } in TestSuiteLog - { testSuiteName = n + { testSuiteName = PD.testName suite , testLogs = l , logFile = testLogDir testSuiteLogPath (fromFlag $ testHumanLog flags) - pkg_descr lbi n l + pkg_descr lbi testName' l } -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't @@ -169,4 +172,4 @@ testOption pkg_descr lbi suite template = env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] + [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] diff --git a/Cabal/Distribution/Simple/Test/LibV09.hs b/Cabal/Distribution/Simple/Test/LibV09.hs index 95b44582b51..6a044e341e6 100644 --- a/Cabal/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/Distribution/Simple/Test/LibV09.hs @@ -10,6 +10,7 @@ module Distribution.Simple.Test.LibV09 ) where import Prelude () +import Distribution.Package import Distribution.Compat.Prelude import Distribution.Compat.CreatePipe @@ -64,15 +65,15 @@ runTest pkg_descr lbi clbi flags suite = do -- Remove old .tix files if appropriate. unless (fromFlag $ testKeepTix flags) $ do - let tDir = tixDir distPref way $ PD.testName suite + let tDir = tixDir distPref way testName' exists' <- doesDirectoryExist tDir when exists' $ removeDirectoryRecursive tDir -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite + createDirectoryIfMissing True $ tixDir distPref way testName' -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ PD.testName suite + notice verbosity $ summarizeSuiteStart testName' suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do @@ -82,7 +83,7 @@ runTest pkg_descr lbi clbi flags suite = do (Just wIn, _, _, process) <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way (PD.testName suite) + tixFile = pwd tixFilePath distPref way testName' pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) : existingEnv shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] @@ -116,14 +117,14 @@ runTest pkg_descr lbi clbi flags suite = do let finalLogName l = testLogDir testSuiteLogPath (fromFlag $ testHumanLog flags) pkg_descr lbi - (testSuiteName l) (testLogs l) + (unUnqualComponentName $ testSuiteName l) (testLogs l) -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read) -- TODO: eradicateNoParse $ readFile tempLog -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' appendFile (logFile suiteLog) logText @@ -148,6 +149,8 @@ runTest pkg_descr lbi clbi flags suite = do return suiteLog where + testName' = unUnqualComponentName $ PD.testName suite + deleteIfExists file = do exists <- doesFileExist file when exists $ removeFile file @@ -173,13 +176,13 @@ testOption pkg_descr lbi suite template = env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] + [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] -- Test stub ---------- -- | The name of the stub executable associated with a library 'TestSuite'. stubName :: PD.TestSuite -> FilePath -stubName t = PD.testName t ++ "Stub" +stubName t = unUnqualComponentName (PD.testName t) ++ "Stub" -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'. @@ -260,7 +263,7 @@ stubRunTests tests = do -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling -- Cabal process to read. -stubWriteLog :: FilePath -> String -> TestLogs -> NoCallStackIO () +stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> NoCallStackIO () stubWriteLog f n logs = do let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } writeFile (logFile testLog) $ show testLog diff --git a/Cabal/Distribution/Simple/Test/Log.hs b/Cabal/Distribution/Simple/Test/Log.hs index ef14020ba84..8264b465f87 100644 --- a/Cabal/Distribution/Simple/Test/Log.hs +++ b/Cabal/Distribution/Simple/Test/Log.hs @@ -27,6 +27,7 @@ import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite import Distribution.Verbosity +import Distribution.Text -- | Logs all test results for a package, broken down first by test suite and -- then by test case. @@ -49,7 +50,7 @@ localPackageLog pkg_descr lbi = PackageLog -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog - { testSuiteName :: String + { testSuiteName :: UnqualComponentName , testLogs :: TestLogs , logFile :: FilePath -- path to human-readable log file } @@ -153,7 +154,7 @@ summarizeTest verbosity details t = -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String summarizeSuiteFinish testLog = unlines - [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr + [ "Test suite " ++ display (testSuiteName testLog) ++ ": " ++ resStr , "Test suite logged to: " ++ logFile testLog ] where resStr = map toUpper (resultString $ testLogs testLog) diff --git a/Cabal/Distribution/Simple/UHC.hs b/Cabal/Distribution/Simple/UHC.hs index b595d6d8cd8..e0d233eec63 100644 --- a/Cabal/Distribution/Simple/UHC.hs +++ b/Cabal/Distribution/Simple/UHC.hs @@ -202,7 +202,7 @@ buildExe verbosity _pkg_descr lbi exe clbi = do lbi (buildInfo exe) clbi (buildDir lbi) verbosity -- output file - ++ ["--output", buildDir lbi exeName exe] + ++ ["--output", buildDir lbi display (exeName exe)] -- main source module ++ [modulePath exe] runUhcProg uhcArgs diff --git a/Cabal/Distribution/Types/Benchmark.hs b/Cabal/Distribution/Types/Benchmark.hs index ce7c0bfe6f6..0c00470ca1a 100644 --- a/Cabal/Distribution/Types/Benchmark.hs +++ b/Cabal/Distribution/Types/Benchmark.hs @@ -17,11 +17,12 @@ import Distribution.Types.BenchmarkType import Distribution.Types.BenchmarkInterface import Distribution.ModuleName +import Distribution.Package -- | A \"benchmark\" stanza in a cabal file. -- data Benchmark = Benchmark { - benchmarkName :: String, + benchmarkName :: UnqualComponentName, benchmarkInterface :: BenchmarkInterface, benchmarkBuildInfo :: BuildInfo } @@ -43,11 +44,12 @@ instance Semigroup Benchmark where benchmarkInterface = combine benchmarkInterface, benchmarkBuildInfo = combine benchmarkBuildInfo } - where combine field = field a `mappend` field b - combine' f = case (f a, f b) of - ("", x) -> x - (x, "") -> x - (x, y) -> error "Ambiguous values for benchmark field: '" + where combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for test field: '" ++ x ++ "' and '" ++ y ++ "'" emptyBenchmark :: Benchmark diff --git a/Cabal/Distribution/Types/ComponentName.hs b/Cabal/Distribution/Types/ComponentName.hs index 4efcfc2e0ef..c6b938fcd94 100644 --- a/Cabal/Distribution/Types/ComponentName.hs +++ b/Cabal/Distribution/Types/ComponentName.hs @@ -20,11 +20,11 @@ import Text.PrettyPrint as Disp -- Libraries live in a separate namespace, so must distinguish data ComponentName = CLibName - | CSubLibName String - | CFLibName String - | CExeName String - | CTestName String - | CBenchName String + | CSubLibName UnqualComponentName + | CFLibName UnqualComponentName + | CExeName UnqualComponentName + | CTestName UnqualComponentName + | CBenchName UnqualComponentName deriving (Eq, Generic, Ord, Read, Show) instance Binary ComponentName @@ -32,11 +32,11 @@ instance Binary ComponentName -- Build-target-ish syntax instance Text ComponentName where disp CLibName = Disp.text "lib" - disp (CSubLibName str) = Disp.text ("lib:" ++ str) - disp (CFLibName str) = Disp.text ("flib:" ++ str) - disp (CExeName str) = Disp.text ("exe:" ++ str) - disp (CTestName str) = Disp.text ("test:" ++ str) - disp (CBenchName str) = Disp.text ("bench:" ++ str) + disp (CSubLibName str) = Disp.text "lib:" <<>> disp str + disp (CFLibName str) = Disp.text "flib:" <<>> disp str + disp (CExeName str) = Disp.text "exe:" <<>> disp str + disp (CTestName str) = Disp.text "test:" <<>> disp str + disp (CBenchName str) = Disp.text "bench:" <<>> disp str parse = parseComposite <++ parseSingle where @@ -47,27 +47,24 @@ instance Text ComponentName where , Parse.string "exe:" >> return CExeName , Parse.string "bench:" >> return CBenchName , Parse.string "test:" >> return CTestName ] - -- For now, component names coincide with package name syntax - -- (since they can show up in build-depends, which are parsed - -- as package names.) - fmap (ctor . unPackageName) parse + ctor <$> parse defaultLibName :: ComponentName defaultLibName = CLibName showComponentName :: ComponentName -> String showComponentName CLibName = "library" -showComponentName (CSubLibName name) = "library '" ++ name ++ "'" -showComponentName (CFLibName name) = "foreign library '" ++ name ++ "'" -showComponentName (CExeName name) = "executable '" ++ name ++ "'" -showComponentName (CTestName name) = "test suite '" ++ name ++ "'" -showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" +showComponentName (CSubLibName name) = "library '" ++ display name ++ "'" +showComponentName (CFLibName name) = "foreign library '" ++ display name ++ "'" +showComponentName (CExeName name) = "executable '" ++ display name ++ "'" +showComponentName (CTestName name) = "test suite '" ++ display name ++ "'" +showComponentName (CBenchName name) = "benchmark '" ++ display name ++ "'" --- | This gets the 'String' component name. In fact, it is +-- | This gets the underlying unqualified component name. In fact, it is -- guaranteed to uniquely identify a component, returning -- @Nothing@ if the 'ComponentName' was for the public -- library. -componentNameString :: ComponentName -> Maybe String +componentNameString :: ComponentName -> Maybe UnqualComponentName componentNameString CLibName = Nothing componentNameString (CSubLibName n) = Just n componentNameString (CFLibName n) = Just n diff --git a/Cabal/Distribution/Types/Executable.hs b/Cabal/Distribution/Types/Executable.hs index 2baeffd11a3..aece1e01281 100644 --- a/Cabal/Distribution/Types/Executable.hs +++ b/Cabal/Distribution/Types/Executable.hs @@ -13,9 +13,10 @@ import Distribution.Compat.Prelude import Distribution.Types.BuildInfo import Distribution.ModuleName +import Distribution.Package data Executable = Executable { - exeName :: String, + exeName :: UnqualComponentName, modulePath :: FilePath, buildInfo :: BuildInfo } @@ -34,10 +35,10 @@ instance Semigroup Executable where buildInfo = combine buildInfo } where combine field = field a `mappend` field b - combine' field = case (field a, field b) of - ("","") -> "" - ("", x) -> x - (x, "") -> x + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a (x, y) -> error $ "Ambiguous values for executable field: '" ++ x ++ "' and '" ++ y ++ "'" diff --git a/Cabal/Distribution/Types/ForeignLib.hs b/Cabal/Distribution/Types/ForeignLib.hs index 9f983ed0e38..9096c6f64b5 100644 --- a/Cabal/Distribution/Types/ForeignLib.hs +++ b/Cabal/Distribution/Types/ForeignLib.hs @@ -11,6 +11,7 @@ module Distribution.Types.ForeignLib( import Prelude () import Distribution.Compat.Prelude +import Distribution.Package import Distribution.ModuleName import Distribution.Types.BuildInfo @@ -21,7 +22,7 @@ import Distribution.Types.ForeignLibOption -- the built code is intended for consumption by a non-Haskell client. data ForeignLib = ForeignLib { -- | Name of the foreign library - foreignLibName :: String + foreignLibName :: UnqualComponentName -- | What kind of foreign library is this (static or dynamic). , foreignLibType :: ForeignLibType -- | What options apply to this foreign library (e.g., are we @@ -49,12 +50,12 @@ instance Semigroup ForeignLib where , foreignLibModDefFile = combine foreignLibModDefFile } where combine field = field a `mappend` field b - combine' field = case (field a, field b) of - ("","") -> "" - ("", x) -> x - (x, "") -> x - (x, y) -> error $ "Ambiguous values for foreign library field: '" - ++ x ++ "' and '" ++ y ++ "'" + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" instance Monoid ForeignLib where mempty = ForeignLib { diff --git a/Cabal/Distribution/Types/GenericPackageDescription.hs b/Cabal/Distribution/Types/GenericPackageDescription.hs index 274f0e9d10a..88f44169be6 100644 --- a/Cabal/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal/Distribution/Types/GenericPackageDescription.hs @@ -45,11 +45,11 @@ data GenericPackageDescription = packageDescription :: PackageDescription, genPackageFlags :: [Flag], condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), - condSubLibraries :: [(String, CondTree ConfVar [Dependency] Library)], - condForeignLibs :: [(String, CondTree ConfVar [Dependency] ForeignLib)], - condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], - condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)], - condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] + condSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)], + condForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)], + condExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)], + condBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] } deriving (Show, Eq, Typeable, Data, Generic) diff --git a/Cabal/Distribution/Types/HookedBuildInfo.hs b/Cabal/Distribution/Types/HookedBuildInfo.hs index c5164d74d55..7c04bf12697 100644 --- a/Cabal/Distribution/Types/HookedBuildInfo.hs +++ b/Cabal/Distribution/Types/HookedBuildInfo.hs @@ -8,6 +8,7 @@ module Distribution.Types.HookedBuildInfo ( -- import Distribution.Compat.Prelude import Distribution.Types.BuildInfo +import Distribution.Package -- | 'HookedBuildInfo' is mechanism that hooks can use to -- override the 'BuildInfo's inside packages. One example @@ -59,7 +60,7 @@ import Distribution.Types.BuildInfo -- are obligated to apply any new 'HookedBuildInfo' and then we'd -- get the effect twice. But this does mean we have to re-apply -- it every time. Hey, it's more flexibility. -type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) +type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)]) emptyHookedBuildInfo :: HookedBuildInfo emptyHookedBuildInfo = (Nothing, []) diff --git a/Cabal/Distribution/Types/Library.hs b/Cabal/Distribution/Types/Library.hs index a15588a3dfe..a273771ea4a 100644 --- a/Cabal/Distribution/Types/Library.hs +++ b/Cabal/Distribution/Types/Library.hs @@ -15,9 +15,10 @@ import Distribution.Compat.Prelude import Distribution.Types.BuildInfo import Distribution.Types.ModuleReexport import Distribution.ModuleName +import Distribution.Package data Library = Library { - libName :: Maybe String, + libName :: Maybe UnqualComponentName, exposedModules :: [ModuleName], reexportedModules :: [ModuleReexport], signatures:: [ModuleName], -- ^ What sigs need implementations? diff --git a/Cabal/Distribution/Types/PackageDescription.hs b/Cabal/Distribution/Types/PackageDescription.hs index e51d3e2022f..d84422da1c4 100644 --- a/Cabal/Distribution/Types/PackageDescription.hs +++ b/Cabal/Distribution/Types/PackageDescription.hs @@ -344,14 +344,14 @@ updatePackageDescription (mb_lib_bi, exe_bi) p updateLibrary Nothing mb_lib = mb_lib updateLibrary (Just _) Nothing = Nothing - updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated + updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)] + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeNames updated updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeName updated + updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo) + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeName updated updateExecutable _ [] = [] updateExecutable exe_bi'@(name,bi) (exe:exes) | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes diff --git a/Cabal/Distribution/Types/TestSuite.hs b/Cabal/Distribution/Types/TestSuite.hs index df33e1e4dba..e73b27600eb 100644 --- a/Cabal/Distribution/Types/TestSuite.hs +++ b/Cabal/Distribution/Types/TestSuite.hs @@ -17,11 +17,12 @@ import Distribution.Types.TestType import Distribution.Types.TestSuiteInterface import Distribution.ModuleName +import Distribution.Package -- | A \"test-suite\" stanza in a cabal file. -- data TestSuite = TestSuite { - testName :: String, + testName :: UnqualComponentName, testInterface :: TestSuiteInterface, testBuildInfo :: BuildInfo } @@ -43,11 +44,12 @@ instance Semigroup TestSuite where testInterface = combine testInterface, testBuildInfo = combine testBuildInfo } - where combine field = field a `mappend` field b - combine' f = case (f a, f b) of - ("", x) -> x - (x, "") -> x - (x, y) -> error "Ambiguous values for test field: '" + where combine field = field a `mappend` field b + combine' field = case ( unUnqualComponentName $ field a + , unUnqualComponentName $ field b) of + ("", _) -> field b + (_, "") -> field a + (x, y) -> error $ "Ambiguous values for test field: '" ++ x ++ "' and '" ++ y ++ "'" emptyTestSuite :: TestSuite diff --git a/Cabal/tests/ParserHackageTests.hs b/Cabal/tests/ParserHackageTests.hs index 86559b32a39..1f8261890ec 100644 --- a/Cabal/tests/ParserHackageTests.hs +++ b/Cabal/tests/ParserHackageTests.hs @@ -17,7 +17,7 @@ import System.Environment (getArgs) import System.Exit (exitFailure) import System.FilePath (()) -import Distribution.Package (Dependency) +import Distribution.Package (Dependency, UnqualComponentName) import Distribution.PackageDescription import qualified Codec.Archive.Tar as Tar @@ -330,7 +330,7 @@ packageDescription_ = lens packageDescription $ \s a -> s { packageDescription = condLibrary_ :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) condLibrary_ = lens condLibrary $ \s a -> s { condLibrary = a} -condExecutables_ :: Lens' GenericPackageDescription [(String, CondTree ConfVar [Dependency] Executable)] +condExecutables_ :: Lens' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] condExecutables_ = lens condExecutables $ \s a -> s { condExecutables = a } condTreeData_ :: Lens' (CondTree v c a) a diff --git a/cabal-install/Distribution/Client/BuildTarget.hs b/cabal-install/Distribution/Client/BuildTarget.hs index 2a9baf5d6cb..f204120b8a2 100644 --- a/cabal-install/Distribution/Client/BuildTarget.hs +++ b/cabal-install/Distribution/Client/BuildTarget.hs @@ -42,7 +42,8 @@ module Distribution.Client.BuildTarget ( ) where import Distribution.Package - ( Package(..), PackageId, PackageName, packageName ) + ( Package(..), PackageId, PackageName, packageName + , unUnqualComponentName ) import Distribution.Client.Types ( PackageLocation(..) ) @@ -1123,11 +1124,11 @@ selectComponentInfo pinfo pkg = componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName componentStringName pkg CLibName = display (packageName pkg) -componentStringName _ (CSubLibName name) = name -componentStringName _ (CFLibName name) = name -componentStringName _ (CExeName name) = name -componentStringName _ (CTestName name) = name -componentStringName _ (CBenchName name) = name +componentStringName _ (CSubLibName name) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name componentModules :: Component -> [ModuleName] -- I think it's unlikely users will ask to build a requirement diff --git a/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal-install/Distribution/Client/DistDirLayout.hs index 277b2356f5f..79dad4b924e 100644 --- a/cabal-install/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/Distribution/Client/DistDirLayout.hs @@ -121,9 +121,9 @@ defaultDistDirLayout projectRootDirectory = display (distParamCompilerId params) display (distParamPackageId params) (case fmap componentNameString (distParamComponentName params) of - Nothing -> "" - Just Nothing -> "" - Just (Just str) -> "c" str) + Nothing -> "" + Just Nothing -> "" + Just (Just name) -> "c" display name) (case distParamOptimization params of NoOptimisation -> "noopt" NormalOptimisation -> "" diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 9e6c8f91444..6034d04852e 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -963,14 +963,14 @@ symlinkBinaries verbosity platform comp configFlags installFlags [(_, exe, path)] -> warn verbosity $ "could not create a symlink in " ++ bindir ++ " for " - ++ exe ++ " because the file exists there already but is not " + ++ display exe ++ " because the file exists there already but is not " ++ "managed by cabal. You can create a symlink for this executable " ++ "manually if you wish. The executable file has been installed at " ++ path exes -> warn verbosity $ "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ exe | (_, exe, _) <- exes ] + ++ intercalate ", " [ display exe | (_, exe, _) <- exes ] ++ " because the files exist there already and are not " ++ "managed by cabal. You can create symlinks for these executables " ++ "manually if you wish. The executable files have been installed at " @@ -1590,7 +1590,7 @@ withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension | exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) - , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix + , let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix prefix = substTemplate prefixTemplate suffix = substTemplate suffixTemplate ] where diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index 5ad71076b5a..2a024284fb8 100644 --- a/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/Distribution/Client/InstallSymlink.hs @@ -18,7 +18,7 @@ module Distribution.Client.InstallSymlink ( #ifdef mingw32_HOST_OS -import Distribution.Package (PackageIdentifier) +import Distribution.Package (PackageIdentifier, UnqualComponentName) import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types (BuildOutcomes) import Distribution.Client.Setup (InstallFlags) @@ -31,10 +31,10 @@ symlinkBinaries :: Platform -> Compiler -> InstallFlags -> InstallPlan -> BuildOutcomes - -> IO [(PackageIdentifier, String, FilePath)] + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] symlinkBinaries _ _ _ _ _ _ = return [] -symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool +symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" #else @@ -50,7 +50,8 @@ import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.OptionalStanza import Distribution.Package - ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) + ( PackageIdentifier, UnqualComponentName, unUnqualComponentName + , Package(packageId), UnitId, installedUnitId ) import Distribution.Compiler ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription @@ -65,6 +66,8 @@ import Distribution.Simple.Compiler ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System ( Platform ) +import Distribution.Text + ( display ) import System.Posix.Files ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink @@ -108,7 +111,7 @@ symlinkBinaries :: Platform -> Compiler -> InstallFlags -> InstallPlan -> BuildOutcomes - -> IO [(PackageIdentifier, String, FilePath)] + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] symlinkBinaries platform comp configFlags installFlags plan buildOutcomes = case flagToMaybe (installSymlinkBinDir installFlags) of Nothing -> return [] @@ -132,7 +135,7 @@ symlinkBinaries platform comp configFlags installFlags plan buildOutcomes = -- This is a bit dodgy; probably won't work for Backpack packages ipid = installedUnitId rpkg publicExeName = PackageDescription.exeName exe - privateExeName = prefix ++ publicExeName ++ suffix + privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix prefix = substTemplate pkgid ipid prefixTemplate suffix = substTemplate pkgid ipid suffixTemplate ] where @@ -182,30 +185,32 @@ symlinkBinaries platform comp configFlags installFlags plan buildOutcomes = cinfo = compilerInfo comp (CompilerId compilerFlavor _) = compilerInfoId cinfo -symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir - -- eg @/home/user/bin@ - -> FilePath -- ^ The canonical path of the private bin dir - -- eg @/home/user/.cabal/bin@ - -> String -- ^ The name of the executable to go in the public - -- bin dir, eg @foo@ - -> String -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool -- ^ If creating the symlink was successful. @False@ - -- if there was another file there already that we - -- did not own. Other errors like permission errors - -- just propagate as exceptions. +symlinkBinary :: + FilePath -- ^ The canonical path of the public bin dir eg + -- @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir eg + -- @/home/user/.cabal/bin@ + -> UnqualComponentName -- ^ The name of the executable to go in the public bin + -- dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was successful. @False@ if + -- there was another file there already that we did + -- not own. Other errors like permission errors just + -- propagate as exceptions. symlinkBinary publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName) + ok <- targetOkToOverwrite (publicBindir publicName') (privateBindir privateName) case ok of NotOurFile -> return False NotExists -> mkLink >> return True OkToOverwrite -> rmLink >> mkLink >> return True where + publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir mkLink = createSymbolicLink (relativeBindir privateName) - (publicBindir publicName) - rmLink = removeLink (publicBindir publicName) + (publicBindir publicName') + rmLink = removeLink (publicBindir publicName') -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs index 285ceabb3b6..988b344bf6b 100644 --- a/cabal-install/Distribution/Client/List.hs +++ b/cabal-install/Distribution/Client/List.hs @@ -14,7 +14,8 @@ module Distribution.Client.List ( ) where import Distribution.Package - ( PackageName, Package(..), packageName, packageVersion + ( PackageName, UnqualComponentName + , Package(..), packageName, packageVersion , Dependency(..), simplifyDependency , UnitId ) import Distribution.ModuleName (ModuleName) @@ -287,7 +288,7 @@ data PackageDisplayInfo = PackageDisplayInfo { flags :: [Flag], hasLib :: Bool, hasExe :: Bool, - executables :: [String], + executables :: [UnqualComponentName], modules :: [ModuleName], haddockHtml :: FilePath, haveTarball :: Bool @@ -348,7 +349,7 @@ showPackageDetailedInfo pkginfo = , entry "Author" author hideIfNull reflowLines , entry "Maintainer" maintainer hideIfNull reflowLines , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) + , entry "Executables" executables hideIfNull (commaSep disp) , entry "Flags" flags hideIfNull (commaSep dispFlag) , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) , entry "Documentation" haddockHtml showIfInstalled text diff --git a/cabal-install/Distribution/Client/PackageUtils.hs b/cabal-install/Distribution/Client/PackageUtils.hs index b0983e97f71..9d434befaf5 100644 --- a/cabal-install/Distribution/Client/PackageUtils.hs +++ b/cabal-install/Distribution/Client/PackageUtils.hs @@ -15,7 +15,7 @@ module Distribution.Client.PackageUtils ( ) where import Distribution.Package - ( packageVersion, packageName, Dependency(..), unPackageName ) + ( packageVersion, packageName, Dependency(..), packageNameToUnqualComponentName ) import Distribution.PackageDescription ( PackageDescription(..), libName ) import Distribution.Version @@ -32,5 +32,5 @@ externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) internal (Dependency depName versionRange) = (depName == packageName pkg && packageVersion pkg `withinRange` versionRange) || - (Just (unPackageName depName) `elem` map libName (subLibraries pkg) && + (Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) && isAnyVersion versionRange) diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs index a772098fcd1..c460d94a4d9 100644 --- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs @@ -161,19 +161,19 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ["bin-file" J..= J.String bin] where bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" s s - else InstallDirs.bindir (elabInstallDirs elab) s + then dist_dir "build" display s display s + else InstallDirs.bindir (elabInstallDirs elab) display 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:" <> s - ComponentDeps.ComponentFLib s -> "flib:" <> s - ComponentDeps.ComponentExe s -> "exe:" <> s - ComponentDeps.ComponentTest s -> "test:" <> s - ComponentDeps.ComponentBench s -> "bench:" <> s + 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.ComponentSetup -> "setup" style2str :: Bool -> BuildStyle -> String diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index afcad945eb3..f305b90be5a 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1208,7 +1208,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB = distBuildDirectory (elabDistDirParams elaboratedSharedConfig elab) "build" case Cabal.componentNameString cname of - Just n -> n + Just n -> display n Nothing -> "" | otherwise = InstallDirs.bindir install_dirs @@ -1234,7 +1234,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB display pkgid ++ "-inplace" ++ (case Cabal.componentNameString cname of Nothing -> "" - Just s -> "-" ++ s) + Just s -> "-" ++ display s) BuildAndInstall -> hashedInstalledPackageId (packageHashInputs @@ -1374,7 +1374,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB ElabComponent comp -> case fmap Cabal.componentNameString (compComponentName comp) of - Just (Just n) -> n + Just (Just n) -> display n _ -> "" else InstallDirs.bindir (elabInstallDirs elab)] get_exe_path (InstallPlan.Installed _) = unexpectedState @@ -2196,7 +2196,9 @@ pruneInstallPlanPass2 pkgs = exeTargetsRequiredForRevDeps = -- TODO: allow requesting executable with different name -- than package name - [ ComponentTarget (Cabal.CExeName (unPackageName (packageName (elabPkgSourceId elab)))) + [ ComponentTarget (Cabal.CExeName + $ packageNameToUnqualComponentName + $ packageName $ elabPkgSourceId elab) WholeComponent | installedUnitId elab `Set.member` hasReverseExeDeps ] diff --git a/cabal-install/Distribution/Client/Run.hs b/cabal-install/Distribution/Client/Run.hs index ec29e44010a..161477d7e9f 100644 --- a/cabal-install/Distribution/Client/Run.hs +++ b/cabal-install/Distribution/Client/Run.hs @@ -18,6 +18,9 @@ import Distribution.Types.LocalBuildInfo (componentNameTargets') import Distribution.Client.Utils (tryCanonicalizePath) +import Distribution.Package (UnqualComponentName, + mkUnqualComponentName, + unUnqualComponentName) import Distribution.PackageDescription (Executable (..), TestSuite(..), Benchmark(..), @@ -34,6 +37,7 @@ import Distribution.Simple.Utils (die, notice, warn, addLibraryPath) import Distribution.System (Platform (..)) import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) import qualified Distribution.Simple.GHCJS as GHCJS @@ -69,14 +73,14 @@ splitRunArgs verbosity lbi args = ([] , _) -> Left "Couldn't find any enabled executables." ([exe], []) -> return (False, exe, []) ([exe], (x:xs)) - | x == exeName exe -> return (True, exe, xs) - | otherwise -> return (False, exe, args) - (_ , []) -> Left + | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) + | otherwise -> return (False, exe, args) + (_ , []) -> Left $ "This package contains multiple executables. " ++ "You must pass the executable name as the first argument " ++ "to 'cabal run'." (_ , (x:xs)) -> - case find (\exe -> exeName exe == x) enabledExes of + case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of Nothing -> Left $ "No executable named '" ++ x ++ "'." Just exe -> return (True, exe, xs) where @@ -85,20 +89,20 @@ splitRunArgs verbosity lbi args = maybeWarning :: Maybe String maybeWarning = case args of [] -> Nothing - (x:_) -> lookup x components + (x:_) -> lookup (mkUnqualComponentName x) components where - components :: [(String, String)] -- Component name, message. + components :: [(UnqualComponentName, String)] -- Component name, message. components = - [ (name, "The executable '" ++ name ++ "' is disabled.") + [ (name, "The executable '" ++ display name ++ "' is disabled.") | e <- executables pkg_descr , not . buildable . buildInfo $ e, let name = exeName e] - ++ [ (name, "There is a test-suite '" ++ name ++ "'," + ++ [ (name, "There is a test-suite '" ++ display name ++ "'," ++ " but the `run` command is only for executables.") | t <- testSuites pkg_descr , let name = testName t] - ++ [ (name, "There is a benchmark '" ++ name ++ "'," + ++ [ (name, "There is a benchmark '" ++ display name ++ "'," ++ " but the `run` command is only for executables.") | b <- benchmarks pkg_descr , let name = benchmarkName b] @@ -113,16 +117,17 @@ run verbosity lbi exe exeArgs = do curDir dataDir pkg_descr) (path, runArgs) <- - case compilerFlavor (compiler lbi) of + let exeName' = display $ exeName exe + in case compilerFlavor (compiler lbi) of GHCJS -> do let (script, cmd, cmdArgs) = GHCJS.runCmd (withPrograms lbi) - (buildPref exeName exe exeName exe) + (buildPref exeName' exeName') script' <- tryCanonicalizePath script return (cmd, cmdArgs ++ [script']) _ -> do p <- tryCanonicalizePath $ - buildPref exeName exe (exeName exe <.> exeExtension) + buildPref exeName' (exeName' <.> exeExtension) return (p, []) env <- (dataDirEnvVar:) <$> getEnvironment @@ -136,5 +141,5 @@ run verbosity lbi exe exeArgs = do paths <- depLibraryPaths True False lbi clbi return (addLibraryPath os paths env) else return env - notice verbosity $ "Running " ++ exeName exe ++ "..." + notice verbosity $ "Running " ++ display (exeName exe) ++ "..." rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs index f3308a4a93c..557b8cfd4ed 100644 --- a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs @@ -121,7 +121,8 @@ convGPD os arch cinfo strfl sexes pi -- and thus cannot actually be solved over. We'll do this -- by creating a set of package names which are "internal" -- and dropping them as we convert. - ipns = S.fromList $ [ mkPackageName nm + + ipns = S.fromList $ [ unqualComponentNameToPackageName nm | (nm, _) <- sub_libs ] conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> diff --git a/cabal-install/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install/Distribution/Solver/Types/ComponentDeps.hs index 74070f14b37..cb1244674fd 100644 --- a/cabal-install/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install/Distribution/Solver/Types/ComponentDeps.hs @@ -37,6 +37,7 @@ module Distribution.Solver.Types.ComponentDeps ( ) where import Prelude () +import Distribution.Package (UnqualComponentName) import Distribution.Client.Compat.Prelude hiding (empty,zip) import qualified Data.Map as Map @@ -51,11 +52,11 @@ import qualified Distribution.Types.ComponentName as CN -- | Component of a package. data Component = ComponentLib - | ComponentSubLib String - | ComponentFLib String - | ComponentExe String - | ComponentTest String - | ComponentBench String + | ComponentSubLib UnqualComponentName + | ComponentFLib UnqualComponentName + | ComponentExe UnqualComponentName + | ComponentTest UnqualComponentName + | ComponentBench UnqualComponentName | ComponentSetup deriving (Show, Eq, Ord, Generic) diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 364c83aaf1b..cc4c8eaf32a 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -621,7 +621,8 @@ testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do let extraArgs' | null extraArgs = case names of ComponentNamesUnknown -> [] - ComponentNames names' -> [ name | LBI.CTestName name <- names' ] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CTestName name <- names' ] | otherwise = extraArgs maybeWithSandboxDirOnSearchPath useSandbox $ @@ -703,7 +704,8 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags) let extraArgs' | null extraArgs = case names of ComponentNamesUnknown -> [] - ComponentNames names' -> [name | LBI.CBenchName name <- names'] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CBenchName name <- names'] | otherwise = extraArgs maybeWithSandboxDirOnSearchPath useSandbox $ @@ -1012,7 +1014,7 @@ runAction (buildFlags, buildExFlags) extraArgs globalFlags = do (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags ["exe:" ++ exeName exe] + build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] maybeWithSandboxDirOnSearchPath useSandbox $ run verbosity lbi exe exeArgs diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index ee4057f6072..0d667165479 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -210,7 +210,7 @@ withTest ex test = withTests ex [test] withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable withTests ex tests = - let testCDs = CD.fromList [(CD.ComponentTest name, deps) + let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) | ExTest name deps <- tests] in ex { exAvDeps = exAvDeps ex <> testCDs } @@ -219,7 +219,7 @@ withExe ex exe = withExes ex [exe] withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable withExes ex exes = - let exeCDs = CD.fromList [(CD.ComponentExe name, deps) + let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) | ExExe name deps <- exes] in ex { exAvDeps = exAvDeps ex <> exeCDs } diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index b7d9fc81ca4..0e247c90a01 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -26,6 +26,8 @@ import Distribution.Client.Dependency.Types ( Solver(..) ) import Distribution.Client.Setup (defaultMaxBackjumps) +import Distribution.Package (UnqualComponentName, mkUnqualComponentName) + import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps ( Component(..), ComponentDep, ComponentDeps ) @@ -234,7 +236,7 @@ arbitraryComponentDeps db = dedupComponentNames = nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) - componentName :: Component -> Maybe String + componentName :: Component -> Maybe UnqualComponentName componentName ComponentLib = Nothing componentName ComponentSetup = Nothing componentName (ComponentSubLib n) = Just n @@ -285,9 +287,6 @@ arbitraryDeps db = frequency arbitraryFlagName :: Gen String arbitraryFlagName = (:[]) <$> elements ['A'..'E'] -arbitraryComponentName :: Gen String -arbitraryComponentName = (:[]) <$> elements "ABC" - instance Arbitrary ReorderGoals where arbitrary = ReorderGoals <$> arbitrary @@ -303,12 +302,15 @@ instance Arbitrary Solver where shrink Modular = [] +instance Arbitrary UnqualComponentName where + arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" + instance Arbitrary Component where arbitrary = oneof [ return ComponentLib - , ComponentSubLib <$> arbitraryComponentName - , ComponentExe <$> arbitraryComponentName - , ComponentTest <$> arbitraryComponentName - , ComponentBench <$> arbitraryComponentName + , ComponentSubLib <$> arbitrary + , ComponentExe <$> arbitrary + , ComponentTest <$> arbitrary + , ComponentBench <$> arbitrary , return ComponentSetup ] diff --git a/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs b/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs index 6914f4baeb9..b9b3a195aff 100644 --- a/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs +++ b/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs @@ -14,7 +14,7 @@ suite = do dist_dir <- distDir lbi <- liftIO $ getPersistBuildConfig dist_dir let anticipatedBenchmark = emptyBenchmark - { benchmarkName = "dummy" + { benchmarkName = mkUnqualComponentName "dummy" , benchmarkInterface = BenchmarkExeV10 (mkVersion [1,0]) "dummy.hs" , benchmarkBuildInfo = emptyBuildInfo diff --git a/cabal-testsuite/PackageTests/TestStanza/Check.hs b/cabal-testsuite/PackageTests/TestStanza/Check.hs index c15a6dcaac4..7b37a51357b 100644 --- a/cabal-testsuite/PackageTests/TestStanza/Check.hs +++ b/cabal-testsuite/PackageTests/TestStanza/Check.hs @@ -14,7 +14,7 @@ suite = do dist_dir <- distDir lbi <- liftIO $ getPersistBuildConfig dist_dir let anticipatedTestSuite = emptyTestSuite - { testName = "dummy" + { testName = mkUnqualComponentName "dummy" , testInterface = TestSuiteExeV10 (mkVersion [1,0]) "dummy.hs" , testBuildInfo = emptyBuildInfo { targetBuildDepends = diff --git a/cabal-testsuite/PackageTests/Tests.hs b/cabal-testsuite/PackageTests/Tests.hs index 852d71b002f..746316737f7 100644 --- a/cabal-testsuite/PackageTests/Tests.hs +++ b/cabal-testsuite/PackageTests/Tests.hs @@ -14,6 +14,7 @@ import qualified PackageTests.ForeignLibs.Check import Distribution.Types.TargetInfo import Distribution.Types.LocalBuildInfo +import Distribution.Package import Distribution.Simple.LocalBuildInfo ( absoluteComponentInstallDirs , InstallDirs (..) @@ -25,7 +26,6 @@ import Distribution.System (buildOS, OS(Windows)) import Distribution.Version import Control.Monad - import System.Directory import Test.Tasty (mkTimeout, localOption) @@ -718,7 +718,7 @@ tests config = do lbi <- liftIO $ getPersistBuildConfig dist_dir let pkg_descr = localPkgDescr lbi compiler_id = compilerId (compiler lbi) - cname = CSubLibName "foo-internal" + cname = CSubLibName $ mkUnqualComponentName "foo-internal" [target] = componentNameTargets' pkg_descr lbi cname uid = componentUnitId (targetCLBI target) InstallDirs{libdir=dir,dynlibdir=dyndir} =