1 files changed, 157 insertions, 0 deletions
diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs
new file mode 100644
index 0000000000..7248d84620
--- /dev/null
+++ b/compiler/GHC/Unit/Info.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}
+
+-- |
+-- Package configuration information: essentially the interface to Cabal, with
+-- some utilities
+--
+-- (c) The University of Glasgow, 2004
+--
+module GHC.Unit.Info (
+        -- $package_naming
+
+        -- * UnitId
+        packageConfigId,
+        expandedUnitInfoId,
+        definiteUnitInfoId,
+        installedUnitInfoId,
+
+        -- * The UnitInfo type: information about a unit
+        UnitInfo,
+        InstalledPackageInfo(..),
+        ComponentId(..),
+        SourcePackageId(..),
+        PackageName(..),
+        Version(..),
+        defaultUnitInfo,
+        sourcePackageIdString,
+        packageNameString,
+        pprUnitInfo,
+    ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.PackageDb
+import Data.Version
+
+import GHC.Data.FastString
+import GHC.Utils.Outputable
+import GHC.Types.Module as Module
+import GHC.Types.Unique
+
+-- -----------------------------------------------------------------------------
+-- Our UnitInfo type is the InstalledPackageInfo from ghc-boot,
+-- which is similar to a subset of the InstalledPackageInfo type from Cabal.
+
+type UnitInfo = InstalledPackageInfo
+                       ComponentId
+                       SourcePackageId
+                       PackageName
+                       Module.InstalledUnitId
+                       Module.UnitId
+                       Module.ModuleName
+                       Module.Module
+
+-- TODO: there's no need for these to be FastString, as we don't need the uniq
+--       feature, but ghc doesn't currently have convenient support for any
+--       other compact string types, e.g. plain ByteString or Text.
+
+newtype SourcePackageId    = SourcePackageId    FastString deriving (Eq, Ord)
+newtype PackageName = PackageName
+   { unPackageName :: FastString
+   }
+   deriving (Eq, Ord)
+
+instance BinaryStringRep SourcePackageId where
+  fromStringRep = SourcePackageId . mkFastStringByteString
+  toStringRep (SourcePackageId s) = bytesFS s
+
+instance BinaryStringRep PackageName where
+  fromStringRep = PackageName . mkFastStringByteString
+  toStringRep (PackageName s) = bytesFS s
+
+instance Uniquable SourcePackageId where
+  getUnique (SourcePackageId n) = getUnique n
+
+instance Uniquable PackageName where
+  getUnique (PackageName n) = getUnique n
+
+instance Outputable SourcePackageId where
+  ppr (SourcePackageId str) = ftext str
+
+instance Outputable PackageName where
+  ppr (PackageName str) = ftext str
+
+defaultUnitInfo :: UnitInfo
+defaultUnitInfo = emptyInstalledPackageInfo
+
+sourcePackageIdString :: UnitInfo -> String
+sourcePackageIdString pkg = unpackFS str
+  where
+    SourcePackageId str = sourcePackageId pkg
+
+packageNameString :: UnitInfo -> String
+packageNameString pkg = unpackFS str
+  where
+    PackageName str = packageName pkg
+
+pprUnitInfo :: UnitInfo -> SDoc
+pprUnitInfo InstalledPackageInfo {..} =
+    vcat [
+      field "name"                 (ppr packageName),
+      field "version"              (text (showVersion packageVersion)),
+      field "id"                   (ppr unitId),
+      field "exposed"              (ppr exposed),
+      field "exposed-modules"      (ppr exposedModules),
+      field "hidden-modules"       (fsep (map ppr hiddenModules)),
+      field "trusted"              (ppr trusted),
+      field "import-dirs"          (fsep (map text importDirs)),
+      field "library-dirs"         (fsep (map text libraryDirs)),
+      field "dynamic-library-dirs" (fsep (map text libraryDynDirs)),
+      field "hs-libraries"         (fsep (map text hsLibraries)),
+      field "extra-libraries"      (fsep (map text extraLibraries)),
+      field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)),
+      field "include-dirs"         (fsep (map text includeDirs)),
+      field "includes"             (fsep (map text includes)),
+      field "depends"              (fsep (map ppr  depends)),
+      field "cc-options"           (fsep (map text ccOptions)),
+      field "ld-options"           (fsep (map text ldOptions)),
+      field "framework-dirs"       (fsep (map text frameworkDirs)),
+      field "frameworks"           (fsep (map text frameworks)),
+      field "haddock-interfaces"   (fsep (map text haddockInterfaces)),
+      field "haddock-html"         (fsep (map text haddockHTMLs))
+    ]
+  where
+    field name body = text name <> colon <+> nest 4 body
+
+-- -----------------------------------------------------------------------------
+-- UnitId (package names, versions and dep hash)
+
+-- $package_naming
+-- #package_naming#
+-- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes
+-- of a package ID, keys of its dependencies, and Cabal flags. You're expected
+-- to pass in the unit id in the @-this-unit-id@ flag. However, for
+-- wired-in packages like @base@ & @rts@, we don't necessarily know what the
+-- version is, so these are handled specially; see #wired_in_packages#.
+
+-- | Get the GHC 'UnitId' right out of a Cabalish 'UnitInfo'
+installedUnitInfoId :: UnitInfo -> InstalledUnitId
+installedUnitInfoId = unitId
+
+packageConfigId :: UnitInfo -> UnitId
+packageConfigId p =
+    if indefinite p
+        then newUnitId (componentId p) (instantiatedWith p)
+        else DefiniteUnitId (DefUnitId (unitId p))
+
+expandedUnitInfoId :: UnitInfo -> UnitId
+expandedUnitInfoId p =
+    newUnitId (componentId p) (instantiatedWith p)
+
+definiteUnitInfoId :: UnitInfo -> Maybe DefUnitId
+definiteUnitInfoId p =
+    case packageConfigId p of
+        DefiniteUnitId def_uid -> Just def_uid
+        _ -> Nothing