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
( existsAndIsMoreRecentThan, defaultPackageDesc, 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
( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) )
newtype Check a = Check {
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
(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 (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 (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 :: (ConfigFlags, ConfigExFlags)
savedFlags@(ConfigFlags
_, ConfigExFlags
_) <- String -> IO (ConfigFlags, ConfigExFlags)
readConfigFlags String
dist
Bool
useNix <- (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
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
Verbosity -> String -> Bool -> GlobalFlags -> SavedConfig -> IO ()
nixInstantiate Verbosity
verbosity String
dist Bool
False GlobalFlags
globalFlags SavedConfig
config
SavedConfig -> IO SavedConfig
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 (m :: * -> *) a. Monad m => a -> m a
return SavedConfig
config'
where
checkVerb :: Check (ConfigFlags, b)
checkVerb :: 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 :: Flag Verbosity
configVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
verbosity}
(Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
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 :: 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
String
savedDist <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)
let distChanged :: Bool
distChanged :: Bool
distChanged = String
dist String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
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 { configDistPref :: Flag String
configDistPref = String -> Flag String
forall a. a -> Flag a
toFlag String
dist }
(Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Any
Any Bool
distChanged, (ConfigFlags
configFlags', b
configExFlags))
checkOutdated :: Check (ConfigFlags, b)
checkOutdated :: 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
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"
Bool
userPackageEnvironmentFileModified <-
String -> String -> IO Bool
existsAndIsMoreRecentThan String
userPackageEnvironmentFile 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")
String
descrFile <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> IO String
defaultPackageDesc Verbosity
verbosity) String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return
(Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (ConfigFlags -> Flag String
configCabalFilePath ConfigFlags
configFlags))
Bool
outdated <- String -> String -> IO Bool
existsAndIsMoreRecentThan String
descrFile 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 (String
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 (m :: * -> *) a. Monad m => a -> m a
return (Any
failed, (ConfigFlags, b)
flags)