haskell · ezyang · Apr 2, 2017 · Mar 22, 2017 · Mar 24, 2017 · Mar 22, 2017
diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs
@@ -220,8 +220,11 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
                                     (mkAbiHash "inplace") lib' lbi clbi
 
         debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)
-        registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance
+        registerPackage verbosity (compiler lbi) (withPrograms lbi)
                         (withPackageDB lbi) installedPkgInfo
+                        HcPkg.defaultRegisterOptions {
+                          HcPkg.registerMultiInstance = True
+                        }
         return (Just installedPkgInfo)
       else return Nothing
 
@@ -279,8 +282,11 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes
     -- NB: need to enable multiple instances here, because on 7.10+
     -- the package name is the same as the library, and we still
     -- want the registration to go through.
-    registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance
+    registerPackage verbosity (compiler lbi) (withPrograms lbi)
                     (withPackageDB lbi) ipi
+                    HcPkg.defaultRegisterOptions {
+                      HcPkg.registerMultiInstance = True
+                    }
     let ebi = buildInfo exe
         exe' = exe { buildInfo = addExtraCSources ebi extras }
     buildExe verbosity numJobs pkg_descr lbi exe' exeClbi

diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs
@@ -1617,6 +1617,7 @@ hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcPkgProg
                                    , HcPkg.requiresDirDbs  = v >= [7,10]
                                    , HcPkg.nativeMultiInstance  = v >= [7,10]
                                    , HcPkg.recacheMultiInstance = v >= [6,12]
+                                   , HcPkg.suppressFilesCheck   = v >= [6,6]
                                    }
   where
     v               = versionNumbers ver
@@ -1626,18 +1627,13 @@ hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcPkgProg
 registerPackage
   :: Verbosity
   -> ProgramDb
-  -> HcPkg.MultiInstance
   -> PackageDBStack
   -> InstalledPackageInfo
+  -> HcPkg.RegisterOptions
   -> IO ()
-registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo
-  | HcPkg.MultiInstance <- multiInstance
-  = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity
-      packageDbs installedPkgInfo
-
-  | otherwise
-  = HcPkg.reregister (hcPkgInfo progdb) verbosity
-      packageDbs (Right installedPkgInfo)
+registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
+    HcPkg.register (hcPkgInfo progdb) verbosity packageDbs
+                   installedPkgInfo registerOptions
 
 pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
 pkgRoot verbosity lbi = pkgRoot'

diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs
@@ -806,18 +806,13 @@ adjustExts hiSuf objSuf opts =
 
 registerPackage :: Verbosity
                 -> ProgramDb
-                -> HcPkg.MultiInstance
                 -> PackageDBStack
                 -> InstalledPackageInfo
+                -> HcPkg.RegisterOptions
                 -> IO ()
-registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo
-  | HcPkg.MultiInstance <- multiInstance
-  = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity
-      packageDbs installedPkgInfo
-
-  | otherwise
-  = HcPkg.reregister (hcPkgInfo progdb) verbosity
-      packageDbs (Right installedPkgInfo)
+registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
+    HcPkg.register (hcPkgInfo progdb) verbosity packageDbs
+                   installedPkgInfo registerOptions
 
 componentGhcOptions :: Verbosity -> LocalBuildInfo
                     -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
@@ -864,6 +859,7 @@ hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg
                                    , HcPkg.requiresDirDbs  = ver >= v7_10
                                    , HcPkg.nativeMultiInstance  = ver >= v7_10
                                    , HcPkg.recacheMultiInstance = True
+                                   , HcPkg.suppressFilesCheck   = True
                                    }
   where
     v7_10 = mkVersion [7,10]

diff --git a/Cabal/Distribution/Simple/LHC.hs b/Cabal/Distribution/Simple/LHC.hs
@@ -758,10 +758,11 @@ registerPackage
   -> ProgramDb
   -> PackageDBStack
   -> InstalledPackageInfo
+  -> HcPkg.RegisterOptions
   -> IO ()
-registerPackage verbosity progdb packageDbs installedPkgInfo =
-  HcPkg.reregister (hcPkgInfo progdb) verbosity packageDbs
-    (Right installedPkgInfo)
+registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
+    HcPkg.register (hcPkgInfo progdb) verbosity packageDbs
+                   installedPkgInfo registerOptions
 
 hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
 hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = lhcPkgProg
@@ -772,6 +773,7 @@ hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = lhcPkgProg
                                    , HcPkg.requiresDirDbs  = True
                                    , HcPkg.nativeMultiInstance  = False -- ?
                                    , HcPkg.recacheMultiInstance = False -- ?
+                                   , HcPkg.suppressFilesCheck   = True
                                    }
   where
     Just lhcPkgProg = lookupProgram lhcPkgProgram progdb
diff --git a/Cabal/Distribution/Simple/Program/HcPkg.hs b/Cabal/Distribution/Simple/Program/HcPkg.hs
@@ -13,14 +13,15 @@
 -- Currently only GHC, GHCJS and LHC have hc-pkg programs.
 
 module Distribution.Simple.Program.HcPkg (
+    -- * Types
     HcPkgInfo(..),
-    MultiInstance(..),
+    RegisterOptions(..),
+    defaultRegisterOptions,
 
+    -- * Actions
     init,
     invoke,
     register,
-    reregister,
-    registerMultiInstance,
     unregister,
     recache,
     expose,
@@ -32,8 +33,6 @@ module Distribution.Simple.Program.HcPkg (
     -- * Program invocations
     initInvocation,
     registerInvocation,
-    reregisterInvocation,
-    registerMultiInstanceInvocation,
     unregisterInvocation,
     recacheInvocation,
     exposeInvocation,
@@ -78,11 +77,9 @@ data HcPkgInfo = HcPkgInfo
   , requiresDirDbs  :: Bool -- ^ requires directory style package databases
   , nativeMultiInstance  :: Bool -- ^ supports --enable-multi-instance flag
   , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache
+  , suppressFilesCheck   :: Bool -- ^ supports --force-files or equivalent
   }
 
--- | Whether or not use multi-instance functionality.
-data MultiInstance = MultiInstance | NoMultiInstance
-  deriving (Show, Read, Eq, Ord)
 
 -- | Call @hc-pkg@ to initialise a package database at the location {path}.
 --
@@ -106,39 +103,50 @@ invoke hpi verbosity dbStack extraArgs =
     args       = packageDbStackOpts hpi dbStack ++ extraArgs
     invocation = programInvocation (hcPkgProgram hpi) args
 
+-- | Additional variations in the behaviour for 'register'.
+data RegisterOptions = RegisterOptions {
+       -- | Allows re-registering \/ overwriting an existing package
+       registerAllowOverwrite     :: Bool,
+
+       -- | Insist on the ability to register multiple instances of a
+       -- single version of a single package. This will fail if the @hc-pkg@
+       -- does not support it, see 'nativeMultiInstance' and
+       -- 'recacheMultiInstance'.
+       registerMultiInstance      :: Bool,
+
+       -- | Require that no checks are performed on the existence of package
+       -- files mentioned in the registration info. This must be used if
+       -- registering prior to putting the files in their final place. This will
+       -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'.
+       registerSuppressFilesCheck :: Bool
+     }
+
+-- | Defaults are @True@, @False@ and @False@
+defaultRegisterOptions :: RegisterOptions
+defaultRegisterOptions = RegisterOptions {
+    registerAllowOverwrite     = True,
+    registerMultiInstance      = False,
+    registerSuppressFilesCheck = False
+  }
+
 -- | Call @hc-pkg@ to register a package.
 --
 -- > hc-pkg register {filename | -} [--user | --global | --package-db]
 --
 register :: HcPkgInfo -> Verbosity -> PackageDBStack
-         -> Either FilePath
-                   InstalledPackageInfo
+         -> InstalledPackageInfo
+         -> RegisterOptions
          -> IO ()
-register hpi verbosity packagedb pkgFile =
-  runProgramInvocation verbosity
-    (registerInvocation hpi verbosity packagedb pkgFile)
-
+register hpi verbosity packagedbs pkgInfo registerOptions
+  | registerMultiInstance registerOptions
+  , not (nativeMultiInstance hpi || recacheMultiInstance hpi)
+  = die' verbosity $ "HcPkg.register: the compiler does not support "
+       ++ "registering multiple instances of packages."
 
--- | Call @hc-pkg@ to re-register a package.
---
--- > hc-pkg register {filename | -} [--user | --global | --package-db]
---
-reregister :: HcPkgInfo -> Verbosity -> PackageDBStack
-           -> Either FilePath
-                     InstalledPackageInfo
-           -> IO ()
-reregister hpi verbosity packagedb pkgFile =
-  runProgramInvocation verbosity
-    (reregisterInvocation hpi verbosity packagedb pkgFile)
-
-registerMultiInstance :: HcPkgInfo -> Verbosity
-                      -> PackageDBStack
-                      -> InstalledPackageInfo
-                      -> IO ()
-registerMultiInstance hpi verbosity packagedbs pkgInfo
-  | nativeMultiInstance hpi
-  = runProgramInvocation verbosity
-      (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo))
+  | registerSuppressFilesCheck registerOptions
+  , not (suppressFilesCheck hpi)
+  = die' verbosity $ "HcPkg.register: the compiler does not support "
+                  ++ "suppressing checks on files."
 
     -- This is a trick. Older versions of GHC do not support the
     -- --enable-multi-instance flag for ghc-pkg register but it turns out that
@@ -149,14 +157,15 @@ registerMultiInstance hpi verbosity packagedbs pkgInfo
     -- to write the package registration file directly into the package db and
     -- then call hc-pkg recache.
     --
-  | recacheMultiInstance hpi
+  | registerMultiInstance registerOptions
+  , recacheMultiInstance hpi
   = do let pkgdb = last packagedbs
        writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo
        recache hpi verbosity pkgdb
 
   | otherwise
-  = die' verbosity $ "HcPkg.registerMultiInstance: the compiler does not support "
-       ++ "registering multiple instances of packages."
+  = runProgramInvocation verbosity
+      (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions)
 
 writeRegistrationFileDirectly :: Verbosity
                               -> HcPkgInfo
@@ -363,35 +372,30 @@ initInvocation hpi verbosity path =
     args = ["init", path]
         ++ verbosityOpts hpi verbosity
 
-registerInvocation, reregisterInvocation, registerMultiInstanceInvocation
+registerInvocation
   :: HcPkgInfo -> Verbosity -> PackageDBStack
-  -> Either FilePath InstalledPackageInfo
+  -> InstalledPackageInfo
+  -> RegisterOptions
   -> ProgramInvocation
-registerInvocation   = registerInvocation' "register" NoMultiInstance
-reregisterInvocation = registerInvocation' "update"   NoMultiInstance
-registerMultiInstanceInvocation = registerInvocation' "update" MultiInstance
-
-registerInvocation' :: String -> MultiInstance
-                    -> HcPkgInfo -> Verbosity -> PackageDBStack
-                    -> Either FilePath InstalledPackageInfo
-                    -> ProgramInvocation
-registerInvocation' cmdname multiInstance hpi
-                    verbosity packagedbs pkgFileOrInfo =
-    case pkgFileOrInfo of
-      Left pkgFile ->
-        programInvocation (hcPkgProgram hpi) (args pkgFile)
-
-      Right pkgInfo ->
-        (programInvocation (hcPkgProgram hpi) (args "-")) {
-          progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
-          progInvokeInputEncoding = IOEncodingUTF8
-        }
+registerInvocation hpi verbosity packagedbs pkgInfo registerOptions =
+    (programInvocation (hcPkgProgram hpi) (args "-")) {
+      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
+      progInvokeInputEncoding = IOEncodingUTF8
+    }
   where
+    cmdname
+      | registerAllowOverwrite registerOptions = "update"
+      | registerMultiInstance  registerOptions = "update"
+      | otherwise                              = "register"
+
     args file = [cmdname, file]
              ++ (if noPkgDbStack hpi
                    then [packageDbOpts hpi (last packagedbs)]
                    else packageDbStackOpts hpi packagedbs)
-             ++ [ "--enable-multi-instance" | multiInstance == MultiInstance ]
+             ++ [ "--enable-multi-instance"
+                | registerMultiInstance registerOptions ]
+             ++ [ "--force-files"
+                | registerSuppressFilesCheck registerOptions ]
              ++ verbosityOpts hpi verbosity
 
 unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId

diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs
@@ -40,6 +40,8 @@ module Distribution.Simple.Register (
     abiHash,
     invokeHcPkg,
     registerPackage,
+    HcPkg.RegisterOptions(..),
+    HcPkg.defaultRegisterOptions,
     generateRegistrationInfo,
     inplaceInstalledPackageInfo,
     absoluteInstalledPackageInfo,
@@ -168,7 +170,7 @@ registerAll pkg lbi regFlags ipis
                  (libraryComponentName (IPI.sourceLibName ipi))
                  (Just (IPI.instantiatedWith ipi))
                registerPackage verbosity (compiler lbi) (withPrograms lbi)
-                               HcPkg.NoMultiInstance packageDbs ipi
+                               packageDbs ipi HcPkg.defaultRegisterOptions
 
   where
     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
@@ -339,17 +341,17 @@ withHcPkg verbosity name comp progdb f =
 registerPackage :: Verbosity
                 -> Compiler
                 -> ProgramDb
-                -> HcPkg.MultiInstance
                 -> PackageDBStack
                 -> InstalledPackageInfo
+                -> HcPkg.RegisterOptions
                 -> IO ()
-registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo =
+registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions =
   case compilerFlavor comp of
-    GHC   -> GHC.registerPackage   verbosity progdb multiInstance packageDbs installedPkgInfo
-    GHCJS -> GHCJS.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo
-    _ | HcPkg.MultiInstance == multiInstance
+    GHC   -> GHC.registerPackage   verbosity progdb packageDbs installedPkgInfo registerOptions
+    GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions
+    _ | HcPkg.registerMultiInstance registerOptions
           -> die' verbosity "Registering multiple package instances is not yet supported for this compiler"
-    LHC   -> LHC.registerPackage   verbosity      progdb packageDbs installedPkgInfo
+    LHC   -> LHC.registerPackage   verbosity      progdb packageDbs installedPkgInfo registerOptions
     UHC   -> UHC.registerPackage   verbosity comp progdb packageDbs installedPkgInfo
     JHC   -> notice verbosity "Registering for jhc (nothing to do)"
     HaskellSuite {} ->
@@ -363,8 +365,9 @@ writeHcPkgRegisterScript :: Verbosity
                          -> IO ()
 writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
   let genScript installedPkgInfo =
-          let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal
-                              packageDbs (Right installedPkgInfo)
+          let invocation  = HcPkg.registerInvocation hpi Verbosity.normal
+                              packageDbs installedPkgInfo
+                              HcPkg.defaultRegisterOptions
           in invocationAsSystemScript buildOS invocation
       scripts = map genScript ipis
       -- TODO: Do something more robust here