Merge pull request #3047 from ezyang/cabal-ghcup

Distinguish between component ID and unit ID.

Author: 23Skidoo

Cabal/Cabal.cabal

@@ -275,7 +275,6 @@ library
     Distribution.GetOpt
     Distribution.Lex
     Distribution.Simple.GHC.Internal
-    Distribution.Simple.GHC.IPI641
     Distribution.Simple.GHC.IPI642
     Distribution.Simple.GHC.IPIConvert
     Distribution.Simple.GHC.ImplInfo

Cabal/Distribution/InstalledPackageInfo.hs

@@ -28,6 +28,7 @@
 
 module Distribution.InstalledPackageInfo (
         InstalledPackageInfo(..),
+        installedComponentId,
         OriginalModule(..), ExposedModule(..),
         ParseResult(..), PError(..), PWarning,
         emptyInstalledPackageInfo,
@@ -40,7 +41,7 @@ module Distribution.InstalledPackageInfo (
 
 import Distribution.ParseUtils
 import Distribution.License
-import Distribution.Package hiding (installedComponentId)
+import Distribution.Package hiding (installedUnitId)
 import qualified Distribution.Package as Package
 import Distribution.ModuleName
 import Distribution.Version
@@ -60,9 +61,9 @@ import GHC.Generics (Generic)
 data InstalledPackageInfo
    = InstalledPackageInfo {
         -- these parts are exactly the same as PackageDescription
-        sourcePackageId    :: PackageId,
-        installedComponentId:: ComponentId,
-        compatPackageKey   :: ComponentId,
+        sourcePackageId   :: PackageId,
+        installedUnitId   :: UnitId,
+        compatPackageKey  :: String,
         license           :: License,
         copyright         :: String,
         maintainer        :: String,
@@ -77,7 +78,6 @@ data InstalledPackageInfo
         abiHash           :: AbiHash,
         exposed           :: Bool,
         exposedModules    :: [ExposedModule],
-        installedInstantiatedWith  :: [(ModuleName, OriginalModule)],
         hiddenModules     :: [ModuleName],
         trusted           :: Bool,
         importDirs        :: [FilePath],
@@ -88,7 +88,7 @@ data InstalledPackageInfo
         extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi
         includeDirs       :: [FilePath],
         includes          :: [String],
-        depends           :: [ComponentId],
+        depends           :: [UnitId],
         ccOptions         :: [String],
         ldOptions         :: [String],
         frameworkDirs     :: [FilePath],
@@ -99,23 +99,27 @@ data InstalledPackageInfo
     }
     deriving (Eq, Generic, Read, Show)
 
+installedComponentId :: InstalledPackageInfo -> ComponentId
+installedComponentId ipi = case installedUnitId ipi of
+                            SimpleUnitId cid -> cid
+
 instance Binary InstalledPackageInfo
 
 instance Package.Package InstalledPackageInfo where
    packageId = sourcePackageId
 
-instance Package.HasComponentId InstalledPackageInfo where
-   installedComponentId = installedComponentId
+instance Package.HasUnitId InstalledPackageInfo where
+   installedUnitId = installedUnitId
 
 instance Package.PackageInstalled InstalledPackageInfo where
    installedDepends = depends
 
 emptyInstalledPackageInfo :: InstalledPackageInfo
 emptyInstalledPackageInfo
    = InstalledPackageInfo {
-        sourcePackageId    = PackageIdentifier (PackageName "") (Version [] []),
-        installedComponentId         = ComponentId "",
-        compatPackageKey   = ComponentId "",
+        sourcePackageId   = PackageIdentifier (PackageName "") (Version [] []),
+        installedUnitId   = mkUnitId "",
+        compatPackageKey  = "",
         license           = UnspecifiedLicense,
         copyright         = "",
         maintainer        = "",
@@ -130,7 +134,6 @@ emptyInstalledPackageInfo
         exposed           = False,
         exposedModules    = [],
         hiddenModules     = [],
-        installedInstantiatedWith  = [],
         trusted           = False,
         importDirs        = [],
         libraryDirs       = [],
@@ -155,16 +158,15 @@ emptyInstalledPackageInfo
 
 data OriginalModule
    = OriginalModule {
-       originalPackageId :: ComponentId,
+       originalPackageId  :: UnitId,
        originalModuleName :: ModuleName
      }
   deriving (Generic, Eq, Read, Show)
 
 data ExposedModule
    = ExposedModule {
        exposedName      :: ModuleName,
-       exposedReexport  :: Maybe OriginalModule,
-       exposedSignature :: Maybe OriginalModule -- This field is unused for now.
+       exposedReexport  :: Maybe OriginalModule
      }
   deriving (Eq, Generic, Read, Show)
 
@@ -178,14 +180,11 @@ instance Text OriginalModule where
         return (OriginalModule ipi m)
 
 instance Text ExposedModule where
-    disp (ExposedModule m reexport signature) =
+    disp (ExposedModule m reexport) =
         Disp.sep [ disp m
                  , case reexport of
                     Just m' -> Disp.sep [Disp.text "from", disp m']
                     Nothing -> Disp.empty
-                 , case signature of
-                    Just m' -> Disp.sep [Disp.text "is", disp m']
-                    Nothing -> Disp.empty
                  ]
     parse = do
         m <- parseModuleNameQ
@@ -194,12 +193,7 @@ instance Text ExposedModule where
             _ <- Parse.string "from"
             Parse.skipSpaces
             fmap Just parse
-        Parse.skipSpaces
-        signature <- Parse.option Nothing $ do
-            _ <- Parse.string "is"
-            Parse.skipSpaces
-            fmap Just parse
-        return (ExposedModule m reexport signature)
+        return (ExposedModule m reexport)
 
 
 instance Binary OriginalModule
@@ -215,7 +209,7 @@ showExposedModules :: [ExposedModule] -> Disp.Doc
 showExposedModules xs
     | all isExposedModule xs = fsep (map disp xs)
     | otherwise = fsep (Disp.punctuate comma (map disp xs))
-    where isExposedModule (ExposedModule _ Nothing Nothing) = True
+    where isExposedModule (ExposedModule _ Nothing) = True
           isExposedModule _ = False
 
 parseExposedModules :: Parse.ReadP r [ExposedModule]
@@ -229,14 +223,6 @@ parseInstalledPackageInfo =
     parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs)
     emptyInstalledPackageInfo
 
-parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule)
-parseInstantiatedWith = do k <- parse
-                           _ <- Parse.char '='
-                           n <- parse
-                           _ <- Parse.char '@'
-                           p <- parse
-                           return (k, OriginalModule p n)
-
 -- -----------------------------------------------------------------------------
 -- Pretty-printing
 
@@ -249,9 +235,6 @@ showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo
 showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
 showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo
 
-showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc
-showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p
-
 -- -----------------------------------------------------------------------------
 -- Description of the fields, for parsing/printing
 
@@ -268,9 +251,10 @@ basicFieldDescrs =
                            packageVersion         (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})
  , simpleField "id"
                            disp                   parse
-                           installedComponentId             (\pk pkg -> pkg{installedComponentId=pk})
+                           installedUnitId             (\pk pkg -> pkg{installedUnitId=pk})
+ -- NB: parse these as component IDs
  , simpleField "key"
-                           disp                   parse
+                           (disp . ComponentId)   (fmap (\(ComponentId s) -> s) parse)
                            compatPackageKey       (\pk pkg -> pkg{compatPackageKey=pk})
  , simpleField "license"
                            disp                   parseLicenseQ
@@ -317,9 +301,6 @@ installedFieldDescrs = [
  , simpleField "abi"
         disp               parse
         abiHash            (\abi    pkg -> pkg{abiHash=abi})
- , listField   "instantiated-with"
-        showInstantiatedWith parseInstantiatedWith
-        installedInstantiatedWith   (\xs    pkg -> pkg{installedInstantiatedWith=xs})
  , boolField   "trusted"
         trusted            (\val pkg -> pkg{trusted=val})
  , listField   "import-dirs"

Cabal/Distribution/Package.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -23,6 +24,9 @@ module Distribution.Package (
 
         -- * Package keys/installed package IDs (used for linker symbols)
         ComponentId(..),
+        UnitId(..),
+        mkUnitId,
+        mkLegacyUnitId,
         getHSLibraryName,
         InstalledPackageId, -- backwards compat
 
@@ -37,7 +41,7 @@ module Distribution.Package (
 
         -- * Package classes
         Package(..), packageName, packageVersion,
-        HasComponentId(..),
+        HasUnitId(..),
         PackageInstalled(..),
   ) where
 
@@ -132,8 +136,21 @@ instance NFData ComponentId where
     rnf (ComponentId pk) = rnf pk
 
 -- | Returns library name prefixed with HS, suitable for filenames
-getHSLibraryName :: ComponentId -> String
-getHSLibraryName (ComponentId s) = "HS" ++ s
+getHSLibraryName :: UnitId -> String
+getHSLibraryName (SimpleUnitId (ComponentId s)) = "HS" ++ s
+
+-- | For now, there is no distinction between component IDs
+-- and unit IDs in Cabal.
+newtype UnitId = SimpleUnitId ComponentId
+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, Text, NFData)
+
+-- | Makes a simple-style UnitId from a string.
+mkUnitId :: String -> UnitId
+mkUnitId = SimpleUnitId . ComponentId
+
+-- | Make an old-style UnitId from a package identifier
+mkLegacyUnitId :: PackageId -> UnitId
+mkLegacyUnitId = SimpleUnitId . ComponentId . display
 
 -- ------------------------------------------------------------
 -- * Package source dependencies
@@ -194,17 +211,17 @@ instance Package PackageIdentifier where
   packageId = id
 
 -- | Packages that have an installed package ID
-class Package pkg => HasComponentId pkg where
-  installedComponentId :: pkg -> ComponentId
+class Package pkg => HasUnitId pkg where
+  installedUnitId :: pkg -> UnitId
 
 -- | Class of installed packages.
 --
 -- The primary data type which is an instance of this package is
 -- 'InstalledPackageInfo', but when we are doing install plans in Cabal install
 -- we may have other, installed package-like things which contain more metadata.
 -- Installed packages have exact dependencies 'installedDepends'.
-class (HasComponentId pkg) => PackageInstalled pkg where
-  installedDepends :: pkg -> [ComponentId]
+class (HasUnitId pkg) => PackageInstalled pkg where
+  installedDepends :: pkg -> [UnitId]
 
 -- -----------------------------------------------------------------------------
 -- ABI hash

Cabal/Distribution/Simple/Bench.hs

@@ -118,6 +118,6 @@ benchOption pkg_descr lbi bm template =
     fromPathTemplate $ substPathTemplate env template
   where
     env = initialPathTemplateEnv
-          (PD.package pkg_descr) (LBI.localComponentId lbi)
+          (PD.package pkg_descr) (LBI.localUnitId lbi)
           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
           [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]

Cabal/Distribution/Simple/Build.hs

@@ -381,19 +381,22 @@ testSuiteLibV09AsLibAndExe pkg_descr
             libExposed     = True,
             libBuildInfo   = bi
           }
+    -- NB: temporary hack; I have a refactor which solves this
     cid = computeComponentId (package pkg_descr)
                              (CTestName (testName test))
-                             (map fst (componentPackageDeps clbi))
+                             (map ((\(SimpleUnitId cid0) -> cid0) . fst)
+                                  (componentPackageDeps clbi))
                              (flagAssignment lbi)
+    uid = SimpleUnitId cid
     (pkg_name, compat_key) = computeCompatPackageKey
                                 (compiler lbi) (package pkg_descr)
-                                (CTestName (testName test)) cid
+                                (CTestName (testName test)) uid
     libClbi = LibComponentLocalBuildInfo
                 { componentPackageDeps = componentPackageDeps clbi
                 , componentPackageRenaming = componentPackageRenaming clbi
-                , componentId = cid
+                , componentUnitId = uid
                 , componentCompatPackageKey = compat_key
-                , componentExposedModules = [IPI.ExposedModule m Nothing Nothing]
+                , componentExposedModules = [IPI.ExposedModule m Nothing]
                 }
     pkg = pkg_descr {
             package      = (package pkg_descr) { pkgName = pkg_name }
@@ -420,7 +423,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
     -- that exposes the relevant test suite library.
     exeClbi = ExeComponentLocalBuildInfo {
                 componentPackageDeps =
-                    (IPI.installedComponentId ipi, packageId ipi)
+                    (IPI.installedUnitId ipi, packageId ipi)
                   : (filter (\(_, x) -> let PackageName name = pkgName x
                                         in name == "Cabal" || name == "base")
                             (componentPackageDeps clbi)),

Cabal/Distribution/Simple/Build/Macros.hs

@@ -30,10 +30,8 @@ import Distribution.Version
          ( Version(versionBranch) )
 import Distribution.PackageDescription
          ( PackageDescription )
-import Distribution.Simple.Compiler
-         ( packageKeySupported )
 import Distribution.Simple.LocalBuildInfo
-         ( LocalBuildInfo(compiler, withPrograms), externalPackageDeps, localComponentId )
+         ( LocalBuildInfo(withPrograms), externalPackageDeps, localComponentId, localCompatPackageKey )
 import Distribution.Simple.Program.Db
          ( configuredPrograms )
 import Distribution.Simple.Program.Types
@@ -96,14 +94,14 @@ generateMacros prefix name version =
   where
     (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
 
--- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key
---   of the current package, if supported by the compiler.
---   NB: this only makes sense for definite packages.
+-- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID
+--   of the current package.
 generateComponentIdMacro :: LocalBuildInfo -> String
-generateComponentIdMacro lbi
-  | packageKeySupported (compiler lbi) =
-      "#define CURRENT_PACKAGE_KEY \"" ++ display (localComponentId lbi) ++ "\"\n\n"
-  | otherwise = ""
+generateComponentIdMacro lbi =
+    concat
+    [ "#define CURRENT_COMPONENT_ID \"" ++ display (localComponentId lbi) ++ "\"\n\n"
+    , "#define CURRENT_PACKAGE_KEY \"" ++ localCompatPackageKey lbi ++ "\"\n\n"
+    ]
 
 fixchar :: Char -> Char
 fixchar '-' = '_'

Cabal/Distribution/Simple/BuildPaths.hs

@@ -76,16 +76,16 @@ haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock"
 -- ---------------------------------------------------------------------------
 -- Library file names
 
-mkLibName :: ComponentId -> String
+mkLibName :: UnitId -> String
 mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a"
 
-mkProfLibName :: ComponentId -> String
+mkProfLibName :: UnitId -> String
 mkProfLibName lib =  "lib" ++ getHSLibraryName lib ++ "_p" <.> "a"
 
 -- Implement proper name mangling for dynamical shared objects
 -- libHS<packagename>-<compilerFlavour><compilerVersion>
 -- e.g. libHSbase-2.1-ghc6.6.1.so
-mkSharedLibName :: CompilerId -> ComponentId -> String
+mkSharedLibName :: CompilerId -> UnitId -> String
 mkSharedLibName (CompilerId compilerFlavor compilerVersion) lib
   = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> dllExtension
   where comp = display compilerFlavor ++ display compilerVersion

Cabal/Distribution/Simple/Compiler.hs

@@ -55,6 +55,7 @@ module Distribution.Simple.Compiler (
         renamingPackageFlagsSupported,
         unifiedIPIDRequired,
         packageKeySupported,
+        unitIdSupported,
 
         -- * Support for profiling detail levels
         ProfDetailLevel(..),
@@ -286,6 +287,10 @@ unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs"
 packageKeySupported :: Compiler -> Bool
 packageKeySupported = ghcSupported "Uses package keys"
 
+-- | Does this compiler support unit IDs?
+unitIdSupported :: Compiler -> Bool
+unitIdSupported = ghcSupported "Uses unit IDs"
+
 -- | Utility function for GHC only features
 ghcSupported :: String -> Compiler -> Bool
 ghcSupported key comp =