Reconfigure.hs

module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where

import Distribution.Client.Compat.Prelude

import Data.Monoid ( Any(..) )
import System.Directory ( doesFileExist )

import Distribution.Verbosity

import Distribution.Simple.Configure ( localBuildInfoFile )
import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag )
import Distribution.Simple.Utils
       ( existsAndIsMoreRecentThan, defaultPackageDesc, info )

import Distribution.Client.Config ( SavedConfig(..) )
import Distribution.Client.Configure ( readConfigFlags )
import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate )
import Distribution.Client.Sandbox
       ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath
       , maybeReinstallAddSourceDeps, updateInstallDirs )
import Distribution.Client.Sandbox.PackageEnvironment
       ( userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types ( UseSandbox(..) )
import Distribution.Client.Setup
       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..)
       , SkipAddSourceDepsCheck(..) )


-- | @Check@ represents a function to check some condition on type @a@. The
-- returned 'Any' is 'True' if any part of the condition failed.
newtype Check a = Check {
  runCheck :: Any          -- Did any previous check fail?
           -> a            -- value returned by previous checks
           -> IO (Any, a)  -- Did this check fail? What value is returned?
}

instance Semigroup (Check a) where
  (<>) c d = Check $ \any0 a0 -> do
    (any1, a1) <- runCheck c any0 a0
    (any2, a2) <- runCheck d (any0 <> any1) a1
    return (any0 <> any1 <> any2, a2)

instance Monoid (Check a) where
  mempty = Check $ \_ a -> return (mempty, a)
  mappend = (<>)


-- | Re-configure the package in the current directory if needed. Deciding
-- when to reconfigure and with which options is convoluted:
--
-- If we are reconfiguring, we must always run @configure@ with the
-- verbosity option we are given; however, that a previous configuration
-- uses a different verbosity setting is not reason enough to reconfigure.
--
-- The package should be configured to use the same \"dist\" prefix as
-- given to the @build@ command, otherwise the build will probably
-- fail. Not only does this determine the \"dist\" prefix setting if we
-- need to reconfigure anyway, but an existing configuration should be
-- invalidated if its \"dist\" prefix differs.
--
-- If the package has never been configured (i.e., there is no
-- LocalBuildInfo), we must configure first, using the default options.
--
-- If the package has been configured, there will be a 'LocalBuildInfo'.
-- If there no package description file, we assume that the
-- 'PackageDescription' is up to date, though the configuration may need
-- to be updated for other reasons (see above). If there is a package
-- description file, and it has been modified since the 'LocalBuildInfo'
-- was generated, then we need to reconfigure.
--
-- The caller of this function may also have specific requirements
-- regarding the flags the last configuration used. For example,
-- 'testAction' requires that the package be configured with test suites
-- enabled. The caller may pass the required settings to this function
-- along with a function to check the validity of the saved 'ConfigFlags';
-- these required settings will be checked first upon determining that
-- a previous configuration exists.
reconfigure
  :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())
     -- ^ configure action
  -> Verbosity
     -- ^ Verbosity setting
  -> FilePath
     -- ^ \"dist\" prefix
  -> UseSandbox
  -> SkipAddSourceDepsCheck
     -- ^ Should we skip the timestamp check for modified
     -- add-source dependencies?
  -> Flag (Maybe Int)
     -- ^ -j flag for reinstalling add-source deps.
  -> Check (ConfigFlags, ConfigExFlags)
     -- ^ Check that the required flags are set.
     -- If they are not set, provide a message explaining the
     -- reason for reconfiguration.
  -> [String]     -- ^ Extra arguments
  -> GlobalFlags  -- ^ Global flags
  -> SavedConfig
  -> IO SavedConfig
reconfigure
  configureAction
  verbosity
  dist
  useSandbox
  skipAddSourceDepsCheck
  numJobsFlag
  check
  extraArgs
  globalFlags
  config
  = do

  savedFlags@(_, _) <- readConfigFlags dist

  useNix <- fmap isJust (findNixExpr globalFlags config)
  alreadyInNixShell <- inNixShell

  if useNix && not alreadyInNixShell
    then do

      -- If we are using Nix, we must reinstantiate the derivation outside
      -- the shell. Eventually, the caller will invoke 'nixShell' which will
      -- rerun cabal inside the shell. That will bring us back to 'reconfigure',
      -- but inside the shell we'll take the second branch, below.

      -- This seems to have a problem: won't 'configureAction' call 'nixShell'
      -- yet again, spawning an infinite tree of subprocesses?
      -- No, because 'nixShell' doesn't spawn a new process if it is already
      -- running in a Nix shell.

      nixInstantiate verbosity dist False globalFlags config
      return config

    else do

      let checks =
            checkVerb
            <> checkDist
            <> checkOutdated
            <> check
            <> checkAddSourceDeps
      (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags

      let (_, config') =
            updateInstallDirs
            (configUserInstall configFlags)
            (useSandbox, config)

      when force $ configureAction flags extraArgs globalFlags
      return config'

  where

    -- Changing the verbosity does not require reconfiguration, but the new
    -- verbosity should be used if reconfiguring.
    checkVerb = Check $ \_ (configFlags, configExFlags) -> do
      let configFlags' = configFlags { configVerbosity = toFlag verbosity}
      return (mempty, (configFlags', configExFlags))

    -- Reconfiguration is required if @--build-dir@ changes.
    checkDist = Check $ \_ (configFlags, configExFlags) -> do
      -- Always set the chosen @--build-dir@ before saving the flags,
      -- or bad things could happen.
      savedDist <- findSavedDistPref config (configDistPref configFlags)
      let distChanged = dist /= savedDist
      when distChanged $ info verbosity "build directory changed"
      let configFlags' = configFlags { configDistPref = toFlag dist }
      return (Any distChanged, (configFlags', configExFlags))

    checkOutdated = Check $ \_ flags@(configFlags, _) -> do
      let buildConfig = localBuildInfoFile dist

      -- Has the package ever been configured? If not, reconfiguration is
      -- required.
      configured <- doesFileExist buildConfig
      unless configured $ info verbosity "package has never been configured"

      -- Is the configuration older than the sandbox configuration file?
      -- If so, reconfiguration is required.
      sandboxConfig <- getSandboxConfigFilePath globalFlags
      sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig
      when sandboxConfigNewer $
        info verbosity "sandbox was created after the package was configured"

      -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need
      -- to force reconfigure. Note that it's possible to use @cabal.config@
      -- even without sandboxes.
      userPackageEnvironmentFileModified <-
        existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig
      when userPackageEnvironmentFileModified $
        info verbosity ("user package environment file ('"
        ++ userPackageEnvironmentFile ++ "') was modified")

      -- Is the configuration older than the package description?
      descrFile <- maybe (defaultPackageDesc verbosity) return
                   (flagToMaybe (configCabalFilePath configFlags))
      outdated <- existsAndIsMoreRecentThan descrFile buildConfig
      when outdated $ info verbosity (descrFile ++ " was changed")

      let failed =
            Any outdated
            <> Any userPackageEnvironmentFileModified
            <> Any sandboxConfigNewer
            <> Any (not configured)
      return (failed, flags)

    checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do
      let (_, config') =
            updateInstallDirs
            (configUserInstall configFlags)
            (useSandbox, config)

          skipAddSourceDepsCheck'
            | force'    = SkipAddSourceDepsCheck
            | otherwise = skipAddSourceDepsCheck

      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $
        info verbosity "skipping add-source deps check"

      -- Were any add-source dependencies reinstalled in the sandbox?
      depsReinstalled <-
        case skipAddSourceDepsCheck' of
          DontSkipAddSourceDepsCheck ->
            maybeReinstallAddSourceDeps
            verbosity numJobsFlag configFlags globalFlags
            (useSandbox, config')
          SkipAddSourceDepsCheck -> do
            return NoDepsReinstalled

      case depsReinstalled of
        NoDepsReinstalled -> return (mempty, flags)
        ReinstalledSomeDeps -> do
          info verbosity "some add-source dependencies were reinstalled"
          return (Any True, flags)