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
( defaultPackageDesc
, existsAndIsMoreRecentThan
, info
)
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
( ConfigExFlags
, ConfigFlags (..)
, GlobalFlags (..)
)
newtype Check a = Check
{ forall a. Check a -> Any -> a -> IO (Any, a)
runCheck
:: Any
-> a
-> IO (Any, a)
}
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
(any1, 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
(any2, a2) <- runCheck d (any0 <> any1) a1
return (any0 <> any1 <> any2, 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
(<>)
reconfigure
:: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())
-> Verbosity
-> FilePath
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure
(ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()
configureAction
Verbosity
verbosity
String
dist
Flag (Maybe Int)
_numJobsFlag
Check (ConfigFlags, ConfigExFlags)
check
[String]
extraArgs
GlobalFlags
globalFlags
SavedConfig
config =
do
savedFlags@(_, _) <- String -> IO (ConfigFlags, ConfigExFlags)
readConfigFlags String
dist
useNix <- fmap isJust (findNixExpr globalFlags config)
alreadyInNixShell <- inNixShell
if useNix && not alreadyInNixShell
then do
nixInstantiate verbosity dist False globalFlags config
return config
else do
let 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 frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags
let config' :: SavedConfig
config' = Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags) SavedConfig
config
when frc $ configureAction flags extraArgs globalFlags
return config'
where
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 configFlags' :: ConfigFlags
configFlags' :: ConfigFlags
configFlags' = ConfigFlags
configFlags{configVerbosity = 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))
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
savedDist <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)
let distChanged :: Bool
distChanged = String
dist String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
savedDist
when distChanged $ info verbosity "build directory changed"
let configFlags' :: ConfigFlags
configFlags' = ConfigFlags
configFlags{configDistPref = toFlag dist}
return (Any distChanged, (configFlags', 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 buildConfig :: FilePath
buildConfig :: String
buildConfig = String -> String
localBuildInfoFile String
dist
configured <- String -> IO Bool
doesFileExist String
buildConfig
unless configured $ info verbosity "package has never been configured"
userPackageEnvironmentFileModified <-
existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig
when userPackageEnvironmentFileModified $
info
verbosity
( "user package environment file ('"
++ userPackageEnvironmentFile
++ "') was modified"
)
descrFile <-
maybe
(defaultPackageDesc verbosity)
return
(flagToMaybe (configCabalFilePath configFlags))
outdated <- existsAndIsMoreRecentThan descrFile buildConfig
when outdated $ info verbosity (descrFile ++ " was changed")
let 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)
return (failed, flags)