Properly handle --gen-pkg-config and --gen-script flags with internal libraries.

Additionally, ABI computation no longer requires successful
registration, so you can generate scripts in any order.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

.gitignore

@@ -11,6 +11,7 @@ cabal-dev/
 cabal.config
 dist
 dist-*
+register.sh
 
 /Cabal/dist/
 /Cabal/tests/Setup

Cabal/Cabal.cabal

@@ -146,6 +146,8 @@ extra-source-files:
   tests/PackageTests/InternalLibraries/p/q/Q.hs
   tests/PackageTests/InternalLibraries/q/Q.hs
   tests/PackageTests/InternalLibraries/q/q.cabal
+  tests/PackageTests/InternalLibraries/r/R.hs
+  tests/PackageTests/InternalLibraries/r/r.cabal
   tests/PackageTests/Macros/A.hs
   tests/PackageTests/Macros/B.hs
   tests/PackageTests/Macros/Main.hs

Cabal/Distribution/Simple/Build.hs

@@ -468,9 +468,7 @@ createInternalPackageDB verbosity lbi distPref = do
     createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
     return (SpecificPackageDB dbPath)
   where
-      dbPath = case compilerFlavor (compiler lbi) of
-        UHC -> UHC.inplacePackageDbPath lbi
-        _   -> distPref </> "package.conf.inplace"
+    dbPath = internalPackageDBPath lbi distPref
 
 addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
                       -> ProgramDb -> ProgramDb

Cabal/Distribution/Simple/Register.hs

+{-# LANGUAGE PatternGuards #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Simple.Register
@@ -27,6 +28,8 @@ module Distribution.Simple.Register (
     register,
     unregister,
 
+    internalPackageDBPath,
+
     initPackageDB,
     doesPackageDBExist,
     createPackageDB,
@@ -65,15 +68,11 @@ import Distribution.Verbosity as Verbosity
 
 import System.FilePath ((</>), (<.>), isAbsolute)
 import System.Directory
-         ( getCurrentDirectory, removeDirectoryRecursive, removeFile
-         , doesDirectoryExist, doesFileExist )
 
 import Data.Version
-import Control.Monad (when)
+import Control.Monad
 import Data.Maybe
-         ( isJust, fromMaybe, maybeToList )
 import Data.List
-         ( partition, nub )
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 
 -- -----------------------------------------------------------------------------
@@ -87,38 +86,60 @@ register pkg lbi regFlags =
     -- if there is no public library, since no one else can use it
     -- usefully (they're not public.)  If we start supporting scoped
     -- packages, we'll have to relax this.
-    when (hasPublicLib pkg) $
-        let maybeRegister (CLib lib) _clbi =
-                registerOne pkg lbi regFlags lib
-            maybeRegister _comp _clbi = return ()
-        in withAllComponentsInBuildOrder pkg lbi maybeRegister
-
-registerOne :: PackageDescription -> LocalBuildInfo -> RegisterFlags
-            -> Library
-            -> IO ()
-registerOne pkg lbi regFlags lib
+    when (hasPublicLib pkg) $ do
+        -- It's important to register in build order, because ghc-pkg
+        -- will complain if a dependency is not registered.
+        let maybeGenerateOne clbi
+                | CLib lib <- getLocalComponent pkg clbi
+                = fmap Just (generateOne pkg lib lbi clbi regFlags)
+                | otherwise = return Nothing
+        ipis <- fmap catMaybes
+              $ mapM maybeGenerateOne (allComponentsInBuildOrder lbi)
+        registerAll pkg lbi regFlags ipis
+        return ()
+
+generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo
+            -> RegisterFlags
+            -> IO InstalledPackageInfo
+generateOne pkg lib lbi clbi regFlags
   = do
-    let clbi = getComponentLocalBuildInfo lbi (CLibName (libName lib))
-
     absPackageDBs    <- absolutePackageDBPaths packageDbs
-    -- TODO: registration info named base on LIBNAME!!!
     installedPkgInfo <- generateRegistrationInfo
                            verbosity pkg lib lbi clbi inplace reloc distPref
                            (registrationPackageDB absPackageDBs)
-
     info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)
+    return installedPkgInfo
+  where
+    inplace   = fromFlag (regInPlace regFlags)
+    reloc     = relocatable lbi
+    -- FIXME: there's really no guarantee this will work.
+    -- registering into a totally different db stack can
+    -- fail if dependencies cannot be satisfied.
+    packageDbs = nub $ withPackageDB lbi
+                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))
+    distPref  = fromFlag (regDistPref regFlags)
+    verbosity = fromFlag (regVerbosity regFlags)
 
+registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags
+            -> [InstalledPackageInfo]
+            -> IO ()
+registerAll pkg lbi regFlags ipis
+  = do
     when (fromFlag (regPrintId regFlags)) $ do
+      forM_ ipis $ \installedPkgInfo ->
+        -- Only print the public library's IPI
+        when (IPI.sourcePackageId installedPkgInfo == packageId pkg) $
           putStrLn (display (IPI.installedUnitId installedPkgInfo))
 
      -- Three different modes:
     case () of
-     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo
-       | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo
+     _ | modeGenerateRegFile   -> writeRegistrationFileOrDirectory
+       | modeGenerateRegScript -> writeRegisterScript
        | otherwise             -> do
            setupMessage verbosity "Registering" (packageId pkg)
-           registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.NoMultiInstance
-                           packageDbs installedPkgInfo
+           forM_ ipis $ \installedPkgInfo ->
+               registerPackage verbosity (compiler lbi) (withPrograms lbi)
+                               HcPkg.NoMultiInstance packageDbs installedPkgInfo
 
   where
     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
@@ -127,28 +148,40 @@ registerOne pkg lbi regFlags lib
 
     modeGenerateRegScript = fromFlag (regGenScript regFlags)
 
-    inplace   = fromFlag (regInPlace regFlags)
-    reloc     = relocatable lbi
     -- FIXME: there's really no guarantee this will work.
     -- registering into a totally different db stack can
     -- fail if dependencies cannot be satisfied.
     packageDbs = nub $ withPackageDB lbi
                     ++ maybeToList (flagToMaybe  (regPackageDB regFlags))
-    distPref  = fromFlag (regDistPref regFlags)
     verbosity = fromFlag (regVerbosity regFlags)
 
-    writeRegistrationFile installedPkgInfo = do
+    writeRegistrationFileOrDirectory = do
+      -- Handles overwriting both directory and file
+      deletePackageDB regFile
+      case ipis of
+        [installedPkgInfo] -> do
           notice verbosity ("Creating package registration file: " ++ regFile)
           writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)
-
-    writeRegisterScript installedPkgInfo =
+        _ -> do
+          notice verbosity ("Creating package registration directory: " ++ regFile)
+          createDirectory regFile
+          let num_ipis = length ipis
+              lpad m xs = replicate (m - length ys) '0' ++ ys
+                  where ys = take m xs
+              number i = lpad (length (show num_ipis)) (show i)
+          forM_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->
+            -- TODO: This will need a hashUnitId when Backpack comes.
+            writeUTF8File (regFile </> (number i ++ "-" ++ display (IPI.installedUnitId installedPkgInfo)))
+                          (IPI.showInstalledPackageInfo installedPkgInfo)
+
+    writeRegisterScript =
       case compilerFlavor (compiler lbi) of
         JHC -> notice verbosity "Registration scripts not needed for jhc"
         UHC -> notice verbosity "Registration scripts not needed for uhc"
         _   -> withHcPkg
                "Registration scripts are not implemented for this compiler"
                (compiler lbi) (withPrograms lbi)
-               (writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs)
+               (writeHcPkgRegisterScript verbosity ipis packageDbs)
 
 
 generateRegistrationInfo :: Verbosity
@@ -168,12 +201,16 @@ generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packa
   --TODO: the method of setting the UnitId is compiler specific
   --      this aspect should be delegated to a per-compiler helper.
   let comp = compiler lbi
+      lbi' = lbi {
+                withPackageDB = withPackageDB lbi
+                    ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
+             }
   abi_hash <-
     case compilerFlavor comp of
      GHC | compilerVersion comp >= Version [6,11] [] -> do
-            fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi lib clbi
+            fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi
      GHCJS -> do
-            fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi lib clbi
+            fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi
      _ -> return (AbiHash "")
 
   installedPkgInfo <-
@@ -278,14 +315,18 @@ registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo
     _    -> die "Registering is not implemented for this compiler"
 
 writeHcPkgRegisterScript :: Verbosity
-                         -> InstalledPackageInfo
+                         -> [InstalledPackageInfo]
                          -> PackageDBStack
                          -> HcPkg.HcPkgInfo
                          -> IO ()
-writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do
+writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
+  let genScript installedPkgInfo =
           let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal
                               packageDbs (Right installedPkgInfo)
-      regScript   = invocationAsSystemScript buildOS invocation
+          in invocationAsSystemScript buildOS invocation
+      scripts = map genScript ipis
+      -- TODO: Do something more robust here
+      regScript = unlines scripts
 
   notice verbosity ("Creating package registration script: " ++ regScriptFileName)
   writeUTF8File regScriptFileName regScript
@@ -469,3 +510,9 @@ unregScriptFileName :: FilePath
 unregScriptFileName = case buildOS of
                           Windows -> "unregister.bat"
                           _       -> "unregister.sh"
+
+internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
+internalPackageDBPath lbi distPref =
+      case compilerFlavor (compiler lbi) of
+        UHC -> UHC.inplacePackageDbPath lbi
+        _   -> distPref </> "package.conf.inplace"

Cabal/tests/PackageTests/InternalLibraries/p/p/P.hs

 module P where
 import Q
+p = "P: " ++ q

Cabal/tests/PackageTests/InternalLibraries/r/R.hs

+module R where
+import P
+r = "R: " ++ p

Cabal/tests/PackageTests/InternalLibraries/r/r.cabal

+name:                r
+version:             0.1.0.0
+license:             BSD3
+author:              Edward Z. Yang
+maintainer:          ezyang@cs.stanford.edu
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     R
+  build-depends:       base, p
+  default-language:    Haskell2010

Cabal/tests/PackageTests/Tests.hs

@@ -14,6 +14,7 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.InstallDirs ( CopyDest(NoCopyDest) )
 import Distribution.Simple.BuildPaths  ( mkLibName, mkSharedLibName )
 import Distribution.Simple.Compiler    ( compilerId )
+import Distribution.System (buildOS, OS(Windows))
 
 import Control.Monad
 
@@ -301,6 +302,39 @@ tests config = do
               r <- runInstalledExe' "foo" []
               assertOutputContains "I AM THE ONE" r
 
+  -- Test to see if --gen-script works.
+  tcs "InternalLibraries" "gen-script" $ do
+    withPackageDb $ do
+      withPackage "p" $ do
+        cabal_build []
+        cabal "copy" []
+        cabal "register" ["--gen-script"]
+        _ <- if buildOS == Windows
+                then shell "cmd" ["/C", "register.bat"]
+                else shell "./register.sh" []
+        return ()
+      -- Make sure we can see p
+      withPackage "r" $ cabal_install []
+
+  -- Test to see if --gen-pkg-config works.
+  tcs "InternalLibraries" "gen-pkg-config" $ do
+    withPackageDb $ do
+      withPackage "p" $ do
+        cabal_build []
+        cabal "copy" []
+        let dir = "pkg-config.bak"
+        cabal "register" ["--gen-pkg-config=" ++ dir]
+        -- Infelicity! Does not respect CWD.
+        pkg_dir <- packageDir
+        let notHidden = not . isHidden
+            isHidden name = "." `isPrefixOf` name
+        confs <- fmap (sort . filter notHidden)
+               . liftIO $ getDirectoryContents (pkg_dir </> dir)
+        forM_ confs $ \conf -> ghcPkg "register" [pkg_dir </> dir </> conf]
+
+      -- Make sure we can see p
+      withPackage "r" $ cabal_install []
+
   -- Internal libraries used by a statically linked executable:
   -- no libraries should get installed or registered.  (Note,
   -- this does build shared libraries just to make sure they