Merge pull request #4057 from Ericson2314/unqual-component-name

[WIP] Use UnqualComponentName newtype instead of String for component names

Author: Ericson2314

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

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'

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

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

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

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