module Stack.Solver
( checkResolverSpec
, cabalPackagesCheck
, findCabalFiles
, getResolverConstraints
, mergeConstraints
, solveExtraDeps
, solveResolverSpec
, parseCabalOutputLine
) where
import Prelude ()
import Prelude.Compat
import Control.Applicative
import Control.Exception (assert)
import Control.Exception.Safe (tryIO)
import Control.Monad (when,void,join,liftM,unless,mapAndUnzipM, zipWithM_)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Data.Aeson.Extended ( WithJSONWarnings(..), object, (.=), toJSON
, logJSONWarnings)
import qualified Data.ByteString as S
import Data.Char (isSpace)
import Data.Either
import Data.Foldable (forM_)
import Data.Function (on)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import Data.List ( (\\), isSuffixOf, intercalate
, minimumBy, isPrefixOf)
import Data.List.Extra (groupSortOn)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Extra (stripCR)
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Tuple (swap)
import qualified Data.Yaml as Yaml
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.Text as C
import Path
import Path.Find (findFiles)
import Path.IO hiding (findExecutable, findFiles)
import Stack.BuildPlan
import Stack.Config (getLocalPackages)
import Stack.Constants (stackDotYaml, wiredInPackages)
import Stack.Package (printCabalFileWarning
, hpack
, readPackageUnresolved)
import Stack.Setup
import Stack.Setup.Installed
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.FlagName
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Resolver
import Stack.Types.StackT (StackM)
import Stack.Types.Version
import qualified System.Directory as D
import qualified System.FilePath as FP
import System.Process.Read
import Text.Regex.Applicative.Text (match, sym, psym, anySym, few)
import qualified Data.Text.Normalize as T ( normalize , NormalizationMode(NFC) )
data ConstraintType = Constraint | Preference deriving (Eq)
type ConstraintSpec = Map PackageName (Version, Map FlagName Bool)
cabalSolver :: (StackM env m, HasConfig env)
=> EnvOverride
-> [Path Abs Dir]
-> ConstraintType
-> ConstraintSpec
-> ConstraintSpec
-> [String]
-> m (Either [PackageName] ConstraintSpec)
cabalSolver menv cabalfps constraintType
srcConstraints depConstraints cabalArgs =
withSystemTempDir "cabal-solver" $ \dir' -> do
let versionConstraints = fmap fst depConstraints
dir = toFilePath dir'
configLines <- getCabalConfig dir constraintType versionConstraints
let configFile = dir FP.</> "cabal.config"
liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines
tmpdir <- getTempDir
let args = ("--config-file=" ++ configFile)
: "install"
: "--enable-tests"
: "--enable-benchmarks"
: "--dry-run"
: "--reorder-goals"
: "--max-backjumps=-1"
: "--package-db=clear"
: "--package-db=global"
: cabalArgs ++
toConstraintArgs (flagConstraints constraintType) ++
fmap toFilePath cabalfps
catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args))
(\ex -> case ex of
ProcessFailed _ _ _ err -> return $ Left err
_ -> throwM ex)
>>= either parseCabalErrors parseCabalOutput
where
errCheck = T.isInfixOf "Could not resolve dependencies"
linesNoCR = map stripCR . T.lines
cabalBuildErrMsg e =
">>>> Cabal errors begin\n"
<> e
<> "<<<< Cabal errors end\n"
parseCabalErrors err = do
let errExit e = error $ "Could not parse cabal-install errors:\n\n"
++ cabalBuildErrMsg (T.unpack e)
msg = LT.toStrict $ decodeUtf8With lenientDecode err
if errCheck msg then do
$logInfo "Attempt failed.\n"
$logInfo $ cabalBuildErrMsg msg
let pkgs = parseConflictingPkgs msg
mPkgNames = map (C.simpleParse . T.unpack) pkgs
pkgNames = map (fromCabalPackageName . C.pkgName)
(catMaybes mPkgNames)
when (any isNothing mPkgNames) $ do
$logInfo $ "*** Only some package names could be parsed: " <>
T.pack (intercalate ", " (map show pkgNames))
error $ T.unpack $
"*** User packages involved in cabal failure: "
<> T.intercalate ", " (parseConflictingPkgs msg)
if pkgNames /= [] then do
return $ Left pkgNames
else errExit msg
else errExit msg
parseConflictingPkgs msg =
let ls = dropWhile (not . errCheck) $ linesNoCR msg
select s = (T.isPrefixOf "trying:" s
|| T.isPrefixOf "next goal:" s)
&& T.isSuffixOf "(user goal)" s
pkgName = take 1
. T.words
. T.drop 1
. T.dropWhile (/= ':')
in concatMap pkgName (filter select ls)
parseCabalOutput bs = do
let ls = drop 1
$ dropWhile (not . T.isPrefixOf "In order, ")
$ linesNoCR
$ decodeUtf8 bs
(errs, pairs) = partitionEithers $ map parseCabalOutputLine ls
if null errs
then return $ Right (Map.fromList pairs)
else error $ "The following lines from cabal-install output could \
\not be parsed: \n"
++ T.unpack (T.intercalate "\n" errs)
toConstraintArgs userFlagMap =
[formatFlagConstraint package flag enabled
| (package, fs) <- Map.toList userFlagMap
, (flag, enabled) <- Map.toList fs]
formatFlagConstraint package flag enabled =
let sign = if enabled then '+' else '-'
in
"--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag]
flagConstraints Constraint = fmap snd (Map.union srcConstraints
depConstraints)
flagConstraints Preference = fmap snd srcConstraints
parseCabalOutputLine :: Text -> Either Text (PackageName, (Version, Map FlagName Bool))
parseCabalOutputLine t0 = maybe (Left t0) Right . join . match re $ t0
where
re = mk <$> some (psym $ not . isSpace) <*> many (lexeme reMaybeFlag)
reMaybeFlag =
(\s -> Just (True, s)) <$ sym '+' <*> some (psym $ not . isSpace) <|>
(\s -> Just (False, s)) <$ sym '-' <*> some (psym $ not . isSpace) <|>
Nothing <$ sym '*' <* some (psym $ not . isSpace) <|>
Nothing <$ sym '(' <* few anySym <* sym ')'
mk :: String -> [Maybe (Bool, String)] -> Maybe (PackageName, (Version, Map FlagName Bool))
mk ident fl = do
PackageIdentifier name version <-
parsePackageIdentifierFromString ident
fl' <- (traverse . traverse) parseFlagNameFromString $ catMaybes fl
return (name, (version, Map.fromList $ map swap fl'))
lexeme r = some (psym isSpace) *> r
getCabalConfig :: (StackM env m, HasConfig env)
=> FilePath
-> ConstraintType
-> Map PackageName Version
-> m [Text]
getCabalConfig dir constraintType constraints = do
indices <- view $ configL.to configPackageIndices
remotes <- mapM goIndex indices
let cache = T.pack $ "remote-repo-cache: " ++ dir
return $ cache : remotes ++ map goConstraint (Map.toList constraints)
where
goIndex index = do
src <- configPackageIndex $ indexName index
let dstdir = dir FP.</> T.unpack (indexNameText $ indexName index)
dst0 = dstdir FP.</> "00-index.tar"
dst1 = dstdir FP.</> "01-index.tar"
liftIO $ void $ tryIO $ do
D.createDirectoryIfMissing True dstdir
D.copyFile (toFilePath src) dst0
D.copyFile (toFilePath src) dst1
return $ T.concat
[ "remote-repo: "
, indexNameText $ indexName index
, ":http://0.0.0.0/fake-url"
]
goConstraint (name, version) =
assert (not . null . versionString $ version) $
T.concat
[ if constraintType == Constraint
|| name `HashSet.member` wiredInPackages
then "constraint: "
else "preference: "
, T.pack $ packageNameString name
, "=="
, T.pack $ versionString version
]
setupCompiler
:: (StackM env m, HasConfig env, HasGHCVariant env)
=> CompilerVersion
-> m (Maybe ExtraDirs)
setupCompiler compiler = do
let msg = Just $ T.concat
[ "Compiler version (" <> compilerVersionText compiler <> ") "
, "required by your resolver specification cannot be found.\n\n"
, "Please use '--install-ghc' command line switch to automatically "
, "install the compiler or '--system-ghc' to use a suitable "
, "compiler available on your PATH." ]
config <- view configL
(dirs, _, _) <- ensureCompiler SetupOpts
{ soptsInstallIfMissing = configInstallGHC config
, soptsUseSystem = configSystemGHC config
, soptsWantedCompiler = compiler
, soptsCompilerCheck = configCompilerCheck config
, soptsStackYaml = Nothing
, soptsForceReinstall = False
, soptsSanityCheck = False
, soptsSkipGhcCheck = False
, soptsSkipMsys = configSkipMsys config
, soptsUpgradeCabal = False
, soptsResolveMissingGHC = msg
, soptsSetupInfoYaml = defaultSetupInfoYaml
, soptsGHCBindistURL = Nothing
}
return dirs
setupCabalEnv
:: (StackM env m, HasConfig env, HasGHCVariant env)
=> CompilerVersion
-> m EnvOverride
setupCabalEnv compiler = do
mpaths <- setupCompiler compiler
menv0 <- getMinimalEnvOverride
envMap <- removeHaskellEnvVars
<$> augmentPathMap (maybe [] edBins mpaths)
(unEnvOverride menv0)
platform <- view platformL
menv <- mkEnvOverride platform envMap
mcabal <- findExecutable menv "cabal"
case mcabal of
Nothing -> throwM SolverMissingCabalInstall
Just _ -> return ()
mver <- getSystemCompiler menv (whichCompiler compiler)
case mver of
Just (version, _) ->
$logInfo $ "Using compiler: " <> compilerVersionText version
Nothing -> error "Failed to determine compiler version. \
\This is most likely a bug."
return menv
mergeConstraints
:: Map PackageName v
-> Map PackageName (Map p f)
-> Map PackageName (v, Map p f)
mergeConstraints = Map.mergeWithKey
(\_ v f -> Just (v, f))
(fmap (flip (,) Map.empty))
(\m -> if Map.null m then Map.empty
else error "Bug: An entry in flag map must have a corresponding \
\entry in the version map")
solveResolverSpec
:: (StackM env m, HasConfig env, HasGHCVariant env)
=> Path Abs File
-> [Path Abs Dir]
-> ( Resolver
, ConstraintSpec
, ConstraintSpec)
-> m (Either [PackageName] (ConstraintSpec , ConstraintSpec))
solveResolverSpec stackYaml cabalDirs
(resolver, srcConstraints, extraConstraints) = do
$logInfo $ "Using resolver: " <> resolverName resolver
(compilerVer, snapConstraints) <- getResolverConstraints stackYaml resolver
menv <- setupCabalEnv compilerVer
let
depConstraints = Map.union extraConstraints snapConstraints
depOnlyConstraints = Map.difference depConstraints srcConstraints
solver t = cabalSolver menv cabalDirs t srcConstraints depOnlyConstraints $
"-v" :
["--ghcjs" | whichCompiler compilerVer == Ghcjs]
let srcNames = T.intercalate " and " $
["packages from " <> resolverName resolver
| not (Map.null snapConstraints)] ++
[T.pack (show (Map.size extraConstraints) <> " external packages")
| not (Map.null extraConstraints)]
$logInfo "Asking cabal to calculate a build plan..."
unless (Map.null depOnlyConstraints)
($logInfo $ "Trying with " <> srcNames <> " as hard constraints...")
eresult <- solver Constraint
eresult' <- case eresult of
Left _ | not (Map.null depOnlyConstraints) -> do
$logInfo $ "Retrying with " <> srcNames <> " as preferences..."
solver Preference
_ -> return eresult
case eresult' of
Right deps -> do
let
srcs = Map.intersection deps srcConstraints
inSnap = Map.intersection deps snapConstraints
inSnapChanged = Map.differenceWith diffConstraints
inSnap snapConstraints
extra = Map.difference deps (Map.union srcConstraints
snapConstraints)
external = Map.union inSnapChanged extra
let outVers = fmap fst srcs
inVers = fmap fst srcConstraints
bothVers = Map.intersectionWith (\v1 v2 -> (v1, v2))
inVers outVers
unless (outVers `Map.isSubmapOf` inVers) $ do
let msg = "Error: user package versions returned by cabal \
\solver are not the same as the versions in the \
\cabal files:\n"
error $ T.unpack $ msg
<> showItems (map show (Map.toList bothVers))
$logInfo $ "Successfully determined a build plan with "
<> T.pack (show $ Map.size external)
<> " external dependencies."
return $ Right (srcs, external)
Left x -> do
$logInfo $ "*** Failed to arrive at a workable build plan."
return $ Left x
where
diffConstraints
:: (Eq v, Eq a, Ord k)
=> (v, Map k a) -> (v, Map k a) -> Maybe (v, Map k a)
diffConstraints (v, f) (v', f')
| (v == v') && (f `Map.isSubmapOf` f') = Nothing
| otherwise = Just (v, f)
getResolverConstraints
:: (StackM env m, HasConfig env, HasGHCVariant env)
=> Path Abs File
-> Resolver
-> m (CompilerVersion,
Map PackageName (Version, Map FlagName Bool))
getResolverConstraints stackYaml resolver = do
(mbp, _loadedResolver) <- loadResolver (Just stackYaml) resolver
return (mbpCompilerVersion mbp, mbpConstraints mbp)
where
mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi)
mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp)
checkResolverSpec
:: (StackM env m, HasConfig env, HasGHCVariant env)
=> [C.GenericPackageDescription]
-> Maybe (Map PackageName (Map FlagName Bool))
-> Resolver
-> m BuildPlanCheck
checkResolverSpec gpds flags resolver = do
case resolver of
ResolverSnapshot name -> checkSnapBuildPlan gpds flags name
ResolverCompiler {} -> return $ BuildPlanCheckPartial Map.empty Map.empty
ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty
findCabalFiles :: (MonadIO m, MonadLogger m) => Bool -> Path Abs Dir -> m [Path Abs File]
findCabalFiles recurse dir = do
liftIO (findFiles dir isHpack subdirFilter) >>= mapM_ (hpack . parent)
liftIO (findFiles dir isCabal subdirFilter)
where
subdirFilter subdir = recurse && not (isIgnored subdir)
isHpack = (== "package.yaml") . toFilePath . filename
isCabal = (".cabal" `isSuffixOf`) . toFilePath
isIgnored path = "." `isPrefixOf` dirName || dirName `Set.member` ignoredDirs
where
dirName = FP.dropTrailingPathSeparator (toFilePath (dirname path))
ignoredDirs :: Set FilePath
ignoredDirs = Set.fromList
[ "dist"
]
cabalPackagesCheck
:: (StackM env m, HasConfig env, HasGHCVariant env)
=> [Path Abs File]
-> String
-> Maybe String
-> m ( Map PackageName (Path Abs File, C.GenericPackageDescription)
, [Path Abs File])
cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do
when (null cabalfps) $
error noPkgMsg
relpaths <- mapM prettyPath cabalfps
$logInfo $ "Using cabal packages:"
$logInfo $ T.pack (formatGroup relpaths)
(warnings, gpds) <- mapAndUnzipM readPackageUnresolved cabalfps
zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings
let packages = zip cabalfps gpds
normalizeString = T.unpack . T.normalize T.NFC . T.pack
getNameMismatchPkg (fp, gpd)
| (normalizeString . show . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp
= Just fp
| otherwise = Nothing
nameMismatchPkgs = mapMaybe getNameMismatchPkg packages
when (nameMismatchPkgs /= []) $ do
rels <- mapM prettyPath nameMismatchPkgs
error $ "Package name as defined in the .cabal file must match the \
\.cabal file name.\n\
\Please fix the following packages and try again:\n"
<> formatGroup rels
let dupGroups = filter ((> 1) . length)
. groupSortOn (gpdPackageName . snd)
dupAll = concat $ dupGroups packages
pathlen = length . FP.splitPath . toFilePath . fst
getmin = minimumBy (compare `on` pathlen)
dupSelected = map getmin (dupGroups packages)
dupIgnored = dupAll \\ dupSelected
unique = packages \\ dupIgnored
when (dupIgnored /= []) $ do
dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages)
$logWarn $ T.pack $
"Following packages have duplicate package names:\n"
<> intercalate "\n" (map formatGroup dups)
case dupErrMsg of
Nothing -> $logWarn $ T.pack $
"Packages with duplicate names will be ignored.\n"
<> "Packages in upper level directories will be preferred.\n"
Just msg -> error msg
return (Map.fromList
$ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique
, map fst dupIgnored)
formatGroup :: [String] -> String
formatGroup = concatMap (\path -> "- " <> path <> "\n")
reportMissingCabalFiles :: (MonadIO m, MonadThrow m, MonadLogger m)
=> [Path Abs File]
-> Bool
-> m ()
reportMissingCabalFiles cabalfps includeSubdirs = do
allCabalfps <- findCabalFiles includeSubdirs =<< getCurrentDir
relpaths <- mapM prettyPath (allCabalfps \\ cabalfps)
unless (null relpaths) $ do
$logWarn $ "The following packages are missing from the config:"
$logWarn $ T.pack (formatGroup relpaths)
solveExtraDeps
:: (StackM env m, HasEnvConfig env)
=> Bool
-> m ()
solveExtraDeps modStackYaml = do
bconfig <- view buildConfigL
let stackYaml = bcStackYaml bconfig
relStackYaml <- prettyPath stackYaml
$logInfo $ "Using configuration file: " <> T.pack relStackYaml
packages <- getLocalPackages
let cabalDirs = Map.keys packages
noPkgMsg = "No cabal packages found in " <> relStackYaml <>
". Please add at least one directory containing a .cabal \
\file. You can also use 'stack init' to automatically \
\generate the config file."
dupPkgFooter = "Please remove the directories containing duplicate \
\entries from '" <> relStackYaml <> "'."
cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs)
reportMissingCabalFiles cabalfps True
(bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter)
let gpds = Map.elems $ fmap snd bundle
oldFlags = unPackageFlags (bcFlags bconfig)
oldExtraVersions = bcExtraDeps bconfig
resolver = bcResolver bconfig
oldSrcs = gpdPackages gpds
oldSrcFlags = Map.intersection oldFlags oldSrcs
oldExtraFlags = Map.intersection oldFlags oldExtraVersions
srcConstraints = mergeConstraints oldSrcs oldSrcFlags
extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags
let resolver' = toResolverNotLoaded resolver
resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver'
resultSpecs <- case resolverResult of
BuildPlanCheckOk flags ->
return $ Just (mergeConstraints oldSrcs flags, Map.empty)
BuildPlanCheckPartial {} -> do
eres <- solveResolverSpec stackYaml cabalDirs
(resolver', srcConstraints, extraConstraints)
return $ either (const Nothing) Just eres
BuildPlanCheckFail {} ->
throwM $ ResolverMismatch IsSolverCmd resolver (show resolverResult)
(srcs, edeps) <- case resultSpecs of
Nothing -> throwM (SolverGiveUp giveUpMsg)
Just x -> return x
mOldResolver <- view $ configL.to (fmap (projectResolver . fst) . configMaybeProject)
let
flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps))
versions = fmap fst edeps
vDiff v v' = if v == v' then Nothing else Just v
versionsDiff = Map.differenceWith vDiff
newVersions = versionsDiff versions oldExtraVersions
goneVersions = versionsDiff oldExtraVersions versions
fDiff f f' = if f == f' then Nothing else Just f
flagsDiff = Map.differenceWith fDiff
newFlags = flagsDiff flags oldFlags
goneFlags = flagsDiff oldFlags flags
changed = any (not . Map.null) [newVersions, goneVersions]
|| any (not . Map.null) [newFlags, goneFlags]
|| any (/= resolver') mOldResolver
if changed then do
$logInfo ""
$logInfo $ "The following changes will be made to "
<> T.pack relStackYaml <> ":"
printResolver mOldResolver resolver'
printFlags newFlags "* Flags to be added"
printDeps newVersions "* Dependencies to be added"
printFlags goneFlags "* Flags to be deleted"
printDeps goneVersions "* Dependencies to be deleted"
if modStackYaml then do
writeStackYaml stackYaml resolver versions flags
$logInfo $ "Updated " <> T.pack relStackYaml
else do
$logInfo $ "To automatically update " <> T.pack relStackYaml
<> ", rerun with '--update-config'"
else
$logInfo $ "No changes needed to " <> T.pack relStackYaml
where
indent t = T.unlines $ fmap (" " <>) (T.lines t)
printResolver mOldRes res = do
forM_ mOldRes $ \oldRes ->
when (res /= oldRes) $ do
$logInfo $ T.concat
[ "* Resolver changes from "
, resolverName oldRes
, " to "
, resolverName res
]
printFlags fl msg = do
unless (Map.null fl) $ do
$logInfo $ T.pack msg
$logInfo $ indent $ decodeUtf8 $ Yaml.encode
$ object ["flags" .= fl]
printDeps deps msg = do
unless (Map.null deps) $ do
$logInfo $ T.pack msg
$logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object
["extra-deps" .= map fromTuple (Map.toList deps)]
writeStackYaml path res deps fl = do
let fp = toFilePath path
obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return
WithJSONWarnings (ProjectAndConfigMonoid _ _) warnings <-
liftIO (Yaml.decodeFileEither fp) >>= either throwM return
logJSONWarnings fp warnings
let obj' =
HashMap.insert "extra-deps"
(toJSON $ map fromTuple $ Map.toList deps)
$ HashMap.insert ("flags" :: Text) (toJSON fl)
$ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj
liftIO $ Yaml.encodeFile fp obj'
giveUpMsg = concat
[ " - Update external packages with 'stack update' and try again.\n"
, " - Tweak " <> toFilePath stackDotYaml <> " and try again\n"
, " - Remove any unnecessary packages.\n"
, " - Add any missing remote packages.\n"
, " - Add extra dependencies to guide solver.\n"
, " - Adjust resolver.\n"
]
prettyPath
:: forall r t m. (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))
=> Path r t -> m String
prettyPath path = do
eres <- liftIO $ try $ makeRelativeToCurrentDir path
return $ case eres of
Left (_ :: PathParseException) -> toFilePath path
Right res -> toFilePath (res :: Path Rel t)