{-# LANGUAGE DataKinds #-}

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

import Distribution.Client.Compat.Prelude

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

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

import Distribution.Client.Config (SavedConfig (..))
import Distribution.Client.Configure (readConfigFlags)
import Distribution.Client.Nix (findNixExpr, inNixShell, nixInstantiate)
import Distribution.Client.Sandbox (findSavedDistPref, updateInstallDirs)
import Distribution.Client.Sandbox.PackageEnvironment
  ( userPackageEnvironmentFile
  )
import Distribution.Client.Setup
  ( CommonSetupFlags (..)
  , ConfigExFlags
  , ConfigFlags (..)
  , GlobalFlags (..)
  )

-- | @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
  { forall a. Check a -> Any -> a -> IO (Any, a)
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
  <> :: Check a -> Check a -> Check a
(<>) Check a
c Check a
d = (Any -> a -> IO (Any, a)) -> Check a
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> a -> IO (Any, a)) -> Check a)
-> (Any -> a -> IO (Any, a)) -> Check a
forall a b. (a -> b) -> a -> b
$ \Any
any0 a
a0 -> do
    (Any
any1, a
a1) <- Check a -> Any -> a -> IO (Any, a)
forall a. Check a -> Any -> a -> IO (Any, a)
runCheck Check a
c Any
any0 a
a0
    (Any
any2, a
a2) <- Check a -> Any -> a -> IO (Any, a)
forall a. Check a -> Any -> a -> IO (Any, a)
runCheck Check a
d (Any
any0 Any -> Any -> Any
forall a. Semigroup a => a -> a -> a
<> Any
any1) a
a1
    (Any, a) -> IO (Any, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any
any0 Any -> Any -> Any
forall a. Semigroup a => a -> a -> a
<> Any
any1 Any -> Any -> Any
forall a. Semigroup a => a -> a -> a
<> Any
any2, a
a2)

instance Monoid (Check a) where
  mempty :: Check a
mempty = (Any -> a -> IO (Any, a)) -> Check a
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> a -> IO (Any, a)) -> Check a)
-> (Any -> a -> IO (Any, a)) -> Check a
forall a b. (a -> b) -> a -> b
$ \Any
_ a
a -> (Any, a) -> IO (Any, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any
forall a. Monoid a => a
mempty, a
a)
  mappend :: Check a -> Check a -> Check a
mappend = Check a -> Check a -> Check a
forall a. Semigroup a => a -> a -> a
(<>)

-- | 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
  -> SymbolicPath Pkg (Dir Dist)
  -- ^ \"dist\" prefix
  -> 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 :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())
-> Verbosity
-> SymbolicPath Pkg ('Dir Dist)
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure
  (ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()
configureAction
  Verbosity
verbosity
  SymbolicPath Pkg ('Dir Dist)
dist
  Flag (Maybe Int)
_numJobsFlag
  Check (ConfigFlags, ConfigExFlags)
check
  [String]
extraArgs
  GlobalFlags
globalFlags
  SavedConfig
config =
    do
      savedFlags :: (ConfigFlags, ConfigExFlags)
savedFlags@(ConfigFlags
_, ConfigExFlags
_) <- String -> IO (ConfigFlags, ConfigExFlags)
readConfigFlags (String -> IO (ConfigFlags, ConfigExFlags))
-> String -> IO (ConfigFlags, ConfigExFlags)
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
dist

      Bool
useNix <- (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (GlobalFlags -> SavedConfig -> IO (Maybe String)
findNixExpr GlobalFlags
globalFlags SavedConfig
config)
      Bool
alreadyInNixShell <- IO Bool
inNixShell

      if Bool
useNix Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
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.

          Verbosity -> String -> Bool -> GlobalFlags -> SavedConfig -> IO ()
nixInstantiate Verbosity
verbosity (SymbolicPath Pkg ('Dir Dist) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
dist) Bool
False GlobalFlags
globalFlags SavedConfig
config
          SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
config
        else do
          let checks :: Check (ConfigFlags, ConfigExFlags)
              checks :: Check (ConfigFlags, ConfigExFlags)
checks =
                Check (ConfigFlags, ConfigExFlags)
forall b. Check (ConfigFlags, b)
checkVerb
                  Check (ConfigFlags, ConfigExFlags)
-> Check (ConfigFlags, ConfigExFlags)
-> Check (ConfigFlags, ConfigExFlags)
forall a. Semigroup a => a -> a -> a
<> Check (ConfigFlags, ConfigExFlags)
forall b. Check (ConfigFlags, b)
checkDist
                  Check (ConfigFlags, ConfigExFlags)
-> Check (ConfigFlags, ConfigExFlags)
-> Check (ConfigFlags, ConfigExFlags)
forall a. Semigroup a => a -> a -> a
<> Check (ConfigFlags, ConfigExFlags)
forall b. Check (ConfigFlags, b)
checkOutdated
                  Check (ConfigFlags, ConfigExFlags)
-> Check (ConfigFlags, ConfigExFlags)
-> Check (ConfigFlags, ConfigExFlags)
forall a. Semigroup a => a -> a -> a
<> Check (ConfigFlags, ConfigExFlags)
check
          (Any Bool
frc, flags :: (ConfigFlags, ConfigExFlags)
flags@(ConfigFlags
configFlags, ConfigExFlags
_)) <- Check (ConfigFlags, ConfigExFlags)
-> Any
-> (ConfigFlags, ConfigExFlags)
-> IO (Any, (ConfigFlags, ConfigExFlags))
forall a. Check a -> Any -> a -> IO (Any, a)
runCheck Check (ConfigFlags, ConfigExFlags)
checks Any
forall a. Monoid a => a
mempty (ConfigFlags, ConfigExFlags)
savedFlags

          let config' :: SavedConfig
              config' :: SavedConfig
config' = Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags) SavedConfig
config

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
frc (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()
configureAction (ConfigFlags, ConfigExFlags)
flags [String]
extraArgs GlobalFlags
globalFlags
          SavedConfig -> IO SavedConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
config'
    where
      mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
configWorkingDir (ConfigFlags -> Flag (SymbolicPath CWD ('Dir Pkg)))
-> ConfigFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      -- Changing the verbosity does not require reconfiguration, but the new
      -- verbosity should be used if reconfiguring.
      checkVerb :: Check (ConfigFlags, b)
      checkVerb :: forall b. Check (ConfigFlags, b)
checkVerb = (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
 -> Check (ConfigFlags, b))
-> (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a b. (a -> b) -> a -> b
$ \Any
_ (ConfigFlags
configFlags, b
configExFlags) -> do
        let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
            configFlags' :: ConfigFlags
            configFlags' :: ConfigFlags
configFlags' =
              ConfigFlags
configFlags
                { configCommonFlags =
                    common{setupVerbosity = toFlag verbosity}
                }
        (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any
forall a. Monoid a => a
mempty, (ConfigFlags
configFlags', b
configExFlags))

      -- Reconfiguration is required if @--build-dir@ changes.
      checkDist :: Check (ConfigFlags, b)
      checkDist :: forall b. Check (ConfigFlags, b)
checkDist = (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
 -> Check (ConfigFlags, b))
-> (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a b. (a -> b) -> a -> b
$ \Any
_ (ConfigFlags
configFlags, b
configExFlags) -> do
        -- Always set the chosen @--build-dir@ before saving the flags,
        -- or bad things could happen.
        let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
        SymbolicPath Pkg ('Dir Dist)
savedDist <- SavedConfig
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
findSavedDistPref SavedConfig
config (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref CommonSetupFlags
common)
        let distChanged :: Bool
            distChanged :: Bool
distChanged = SymbolicPath Pkg ('Dir Dist)
dist SymbolicPath Pkg ('Dir Dist)
-> SymbolicPath Pkg ('Dir Dist) -> Bool
forall a. Eq a => a -> a -> Bool
/= SymbolicPath Pkg ('Dir Dist)
savedDist
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
distChanged (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
info Verbosity
verbosity String
"build directory changed"
        let configFlags' :: ConfigFlags
            configFlags' :: ConfigFlags
configFlags' =
              ConfigFlags
configFlags
                { configCommonFlags =
                    common{setupDistPref = toFlag dist}
                }
        (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
distChanged, (ConfigFlags
configFlags', b
configExFlags))

      checkOutdated :: Check (ConfigFlags, b)
      checkOutdated :: forall b. Check (ConfigFlags, b)
checkOutdated = (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
 -> Check (ConfigFlags, b))
-> (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a b. (a -> b) -> a -> b
$ \Any
_ flags :: (ConfigFlags, b)
flags@(ConfigFlags
configFlags, b
_) -> do
        let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
            buildConfig, userCabalConfig :: FilePath
            buildConfig :: String
buildConfig = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (SymbolicPathX 'AllowAbsolute Pkg 'File -> String)
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist)
-> SymbolicPathX 'AllowAbsolute Pkg 'File
localBuildInfoFile SymbolicPath Pkg ('Dir Dist)
dist
            userCabalConfig :: String
userCabalConfig = String
userPackageEnvironmentFile

        -- Has the package ever been configured? If not, reconfiguration is
        -- required.
        Bool
configured <- String -> IO Bool
doesFileExist String
buildConfig
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
configured (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
info Verbosity
verbosity String
"package has never been 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.
        Bool
userPackageEnvironmentFileModified <-
          String -> String -> IO Bool
existsAndIsMoreRecentThan String
userCabalConfig String
buildConfig
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
userPackageEnvironmentFileModified (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> String -> IO ()
info
            Verbosity
verbosity
            ( String
"user package environment file ('"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userPackageEnvironmentFile
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"') was modified"
            )

        -- Is the configuration older than the package description?
        SymbolicPathX 'AllowAbsolute Pkg 'File
descrFile <-
          IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
-> (SymbolicPathX 'AllowAbsolute Pkg 'File
    -> IO (SymbolicPathX 'AllowAbsolute Pkg 'File))
-> Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (RelativePath Pkg 'File -> SymbolicPathX 'AllowAbsolute Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath (RelativePath Pkg 'File -> SymbolicPathX 'AllowAbsolute Pkg 'File)
-> IO (RelativePath Pkg 'File)
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> IO (RelativePath Pkg 'File)
defaultPackageDescCwd Verbosity
verbosity)
            SymbolicPathX 'AllowAbsolute Pkg 'File
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Flag (SymbolicPathX 'AllowAbsolute Pkg 'File)
-> Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a. Flag a -> Maybe a
flagToMaybe (CommonSetupFlags -> Flag (SymbolicPathX 'AllowAbsolute Pkg 'File)
setupCabalFilePath CommonSetupFlags
common))
        let descrPath :: String
descrPath = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPathX 'AllowAbsolute Pkg 'File
descrFile
        Bool
outdated <- String -> String -> IO Bool
existsAndIsMoreRecentThan String
descrPath String
buildConfig
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
outdated (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
info Verbosity
verbosity (SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPathX 'AllowAbsolute Pkg 'File
descrFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was changed")

        let failed :: Any
            failed :: Any
failed =
              Bool -> Any
Any Bool
outdated
                Any -> Any -> Any
forall a. Semigroup a => a -> a -> a
<> Bool -> Any
Any Bool
userPackageEnvironmentFileModified
                Any -> Any -> Any
forall a. Semigroup a => a -> a -> a
<> Bool -> Any
Any (Bool -> Bool
not Bool
configured)
        (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any
failed, (ConfigFlags, b)
flags)