{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Stack.Init
( initProject
, InitOpts (..)
) where
import Stack.Prelude
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Foldable as F
import qualified Data.IntMap as IntMap
import Data.List.Extra (groupSortOn)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Normalize as T (normalize , NormalizationMode(NFC))
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import qualified Distribution.Text as C
import qualified Distribution.Version as C
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.Find (findFiles)
import Path.IO hiding (findFiles)
import qualified Paths_stack as Meta
import qualified RIO.FilePath as FP
import RIO.List ((\\), intercalate, intersperse,
isSuffixOf, isPrefixOf)
import RIO.List.Partial (minimumBy)
import Stack.BuildPlan
import Stack.Config (getSnapshots,
makeConcreteResolver)
import Stack.Constants
import Stack.SourceMap
import Stack.Types.Config
import Stack.Types.Resolver
import Stack.Types.Version
initProject
:: (HasConfig env, HasGHCVariant env)
=> Path Abs Dir
-> InitOpts
-> Maybe AbstractResolver
-> RIO env ()
initProject :: forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO env ()
initProject Path Abs Dir
currDir InitOpts
initOpts Maybe AbstractResolver
mresolver = do
let dest :: Path Abs File
dest = Path Abs Dir
currDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
FilePath
reldest <- forall b t. Path b t -> FilePath
toFilePath forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
makeRelativeToCurrentDir Path Abs File
dest
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (InitOpts -> Bool
forceOverwrite InitOpts
initOpts) Bool -> Bool -> Bool
&& Bool
exists) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadIO m, ?callStack::CallStack) =>
FilePath -> m a
throwString
(FilePath
"Error: Stack configuration file " forall a. Semigroup a => a -> a -> a
<> FilePath
reldest forall a. Semigroup a => a -> a -> a
<>
FilePath
" exists, use '--force' to overwrite it.")
[Path Abs Dir]
dirs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) (InitOpts -> [Text]
searchDirs InitOpts
initOpts)
let find :: Path Abs Dir -> RIO env (Set (Path Abs Dir))
find = forall env.
HasConfig env =>
Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs (InitOpts -> Bool
includeSubDirs InitOpts
initOpts)
dirs' :: [Path Abs Dir]
dirs' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs then [Path Abs Dir
currDir] else [Path Abs Dir]
dirs
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Looking for .cabal or package.yaml files to use to init the project."
[Path Abs Dir]
cabaldirs <- forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs Dir -> RIO env (Set (Path Abs Dir))
find [Path Abs Dir]
dirs'
(Map PackageName (Path Abs File, GenericPackageDescription)
bundle, [Path Abs File]
dupPkgs) <- forall env.
(HasConfig env, HasGHCVariant env) =>
[Path Abs Dir]
-> Maybe FilePath
-> RIO
env
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
cabalPackagesCheck [Path Abs Dir]
cabaldirs forall a. Maybe a
Nothing
let makeRelDir :: Path Abs Dir -> FilePath
makeRelDir Path Abs Dir
dir =
case forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
currDir Path Abs Dir
dir of
Maybe (Path Rel Dir)
Nothing
| Path Abs Dir
currDir forall a. Eq a => a -> a -> Bool
== Path Abs Dir
dir -> FilePath
"."
| Bool
otherwise -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
dir
Just Path Rel Dir
rel -> forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Rel Dir
rel
fpToPkgDir :: Path Abs File -> ResolvedPath Dir
fpToPkgDir Path Abs File
fp =
let absDir :: Path Abs Dir
absDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
fp
in forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> FilePath
makeRelDir Path Abs Dir
absDir) Path Abs Dir
absDir
pkgDirs :: Map PackageName (ResolvedPath Dir)
pkgDirs = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Path Abs File -> ResolvedPath Dir
fpToPkgDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Map PackageName (Path Abs File, GenericPackageDescription)
bundle
(RawSnapshotLocation
snapshotLoc, Map PackageName (Map FlagName Bool)
flags, Map PackageName Version
extraDeps, Map PackageName (ResolvedPath Dir)
rbundle) <- forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> Maybe AbstractResolver
-> Map PackageName (ResolvedPath Dir)
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
getDefaultResolver InitOpts
initOpts Maybe AbstractResolver
mresolver Map PackageName (ResolvedPath Dir)
pkgDirs
let ignored :: Map PackageName (Path Abs File, GenericPackageDescription)
ignored = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map PackageName (Path Abs File, GenericPackageDescription)
bundle Map PackageName (ResolvedPath Dir)
rbundle
dupPkgMsg :: FilePath
dupPkgMsg
| [Path Abs File]
dupPkgs forall a. Eq a => a -> a -> Bool
/= [] =
FilePath
"Warning (added by new or init): Some packages were found to " forall a. Semigroup a => a -> a -> a
<>
FilePath
"have names conflicting with others and have been commented " forall a. Semigroup a => a -> a -> a
<>
FilePath
"out in the packages section.\n"
| Bool
otherwise = FilePath
""
missingPkgMsg :: FilePath
missingPkgMsg
| forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored forall a. Ord a => a -> a -> Bool
> Int
0 =
FilePath
"Warning (added by new or init): Some packages were found to " forall a. Semigroup a => a -> a -> a
<>
FilePath
"be incompatible with the resolver and have been left commented " forall a. Semigroup a => a -> a -> a
<>
FilePath
"out in the packages section.\n"
| Bool
otherwise = FilePath
""
extraDepMsg :: FilePath
extraDepMsg
| forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps forall a. Ord a => a -> a -> Bool
> Int
0 =
FilePath
"Warning (added by new or init): Specified resolver could not " forall a. Semigroup a => a -> a -> a
<>
FilePath
"satisfy all dependencies. Some external packages have been " forall a. Semigroup a => a -> a -> a
<>
FilePath
"added as dependencies.\n"
| Bool
otherwise = FilePath
""
makeUserMsg :: t FilePath -> FilePath
makeUserMsg t FilePath
msgs =
let msg :: FilePath
msg = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t FilePath
msgs
in if FilePath
msg forall a. Eq a => a -> a -> Bool
/= FilePath
"" then
FilePath
msg forall a. Semigroup a => a -> a -> a
<> FilePath
"You can omit this message by removing it from " forall a. Semigroup a => a -> a -> a
<>
FilePath
"stack.yaml\n"
else FilePath
""
userMsg :: FilePath
userMsg = forall {t :: * -> *}. Foldable t => t FilePath -> FilePath
makeUserMsg [FilePath
dupPkgMsg, FilePath
missingPkgMsg, FilePath
extraDepMsg]
gpdByDir :: Map (Path Abs Dir) GenericPackageDescription
gpdByDir = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp, GenericPackageDescription
gpd) | (Path Abs File
fp, GenericPackageDescription
gpd) <- forall k a. Map k a -> [a]
Map.elems Map PackageName (Path Abs File, GenericPackageDescription)
bundle]
gpds :: [GenericPackageDescription]
gpds = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map (Path Abs Dir) GenericPackageDescription
gpdByDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute) Map PackageName (ResolvedPath Dir)
rbundle
[PackageLocation]
deps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName Version
extraDeps) forall a b. (a -> b) -> a -> b
$ \(PackageName
n, Version
v) ->
PackageLocationImmutable -> PackageLocation
PLImmutable forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompletePackageLocation -> PackageLocationImmutable
cplComplete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation (PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage (PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
n Version
v CabalFileInfo
CFILatest) forall a. Maybe a
Nothing)
let p :: Project
p = Project
{ projectUserMsg :: Maybe FilePath
projectUserMsg = if FilePath
userMsg forall a. Eq a => a -> a -> Bool
== FilePath
"" then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just FilePath
userMsg
, projectPackages :: [RelFilePath]
projectPackages = forall t. ResolvedPath t -> RelFilePath
resolvedRelative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
Map.elems Map PackageName (ResolvedPath Dir)
rbundle
, projectDependencies :: [RawPackageLocation]
projectDependencies = forall a b. (a -> b) -> [a] -> [b]
map PackageLocation -> RawPackageLocation
toRawPL [PackageLocation]
deps
, projectFlags :: Map PackageName (Map FlagName Bool)
projectFlags = [GenericPackageDescription]
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
removeSrcPkgDefaultFlags [GenericPackageDescription]
gpds Map PackageName (Map FlagName Bool)
flags
, projectResolver :: RawSnapshotLocation
projectResolver = RawSnapshotLocation
snapshotLoc
, projectCompiler :: Maybe WantedCompiler
projectCompiler = forall a. Maybe a
Nothing
, projectExtraPackageDBs :: [FilePath]
projectExtraPackageDBs = []
, projectCurator :: Maybe Curator
projectCurator = forall a. Maybe a
Nothing
, projectDropPackages :: Set PackageName
projectDropPackages = forall a. Monoid a => a
mempty
}
makeRel :: Path Abs File -> RIO env FilePath
makeRel = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b t. Path b t -> FilePath
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
makeRelativeToCurrentDir
indent :: Text -> Text
indent Text
t = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
t)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Initialising configuration using resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapshotLoc
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Total number of user packages considered: "
forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
bundle forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs File]
dupPkgs forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning! Ignoring "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs)
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" duplicate packages:"
[FilePath]
rels <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs File -> RIO env FilePath
makeRel [Path Abs File]
dupPkgs
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ Text -> Text
indent forall a b. (a -> b) -> a -> b
$ [FilePath] -> Text
showItems [FilePath]
rels
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning! Ignoring "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored)
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" packages due to dependency conflicts:"
[FilePath]
rels <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs File -> RIO env FilePath
makeRel (forall k a. Map k a -> [a]
Map.elems (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Map PackageName (Path Abs File, GenericPackageDescription)
ignored))
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ Text -> Text
indent forall a b. (a -> b) -> a -> b
$ [FilePath] -> Text
showItems [FilePath]
rels
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning! " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps)
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" external dependencies were added."
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
(if Bool
exists then Utf8Builder
"Overwriting existing configuration file: "
else Utf8Builder
"Writing configuration to file: ")
forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
reldest
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
dest
forall a b. (a -> b) -> a -> b
$ Project -> [FilePath] -> [FilePath] -> Builder
renderStackYaml Project
p
(forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir -> FilePath
makeRelDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Map PackageName (Path Abs File, GenericPackageDescription)
ignored)
(forall a b. (a -> b) -> [a] -> [b]
map (Path Abs Dir -> FilePath
makeRelDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> Path b Dir
parent) [Path Abs File]
dupPkgs)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"All done."
renderStackYaml :: Project -> [FilePath] -> [FilePath] -> B.Builder
renderStackYaml :: Project -> [FilePath] -> [FilePath] -> Builder
renderStackYaml Project
p [FilePath]
ignoredPackages [FilePath]
dupPackages =
case forall a. ToJSON a => a -> Value
Yaml.toJSON Project
p of
Yaml.Object Object
o -> Object -> Builder
renderObject Object
o
Value
_ -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Yaml.encode Project
p
where
renderObject :: Object -> Builder
renderObject Object
o =
ByteString -> Builder
B.byteString ByteString
headerHelp
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
"\n\n"
forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (Object -> (Key, ByteString) -> Builder
goComment Object
o) [(Key, ByteString)]
comments
forall a. Semigroup a => a -> a -> a
<> forall {v}. ToJSON v => KeyMap v -> Builder
goOthers (Object
o forall v v'. KeyMap v -> KeyMap v' -> KeyMap v
`KeyMap.difference` forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key, ByteString)]
comments)
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
footerHelp
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
goComment :: Object -> (Key, ByteString) -> Builder
goComment Object
o (Key
name, ByteString
comment) =
case (Value -> Builder
convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
name Object
o) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {a}. (Eq a, IsString a, IsString a) => a -> Maybe a
nonPresentValue Key
name of
Maybe Builder
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Key
name forall a. Eq a => a -> a -> Bool
== Key
"user-message") forall a. Monoid a => a
mempty
Just Builder
v ->
ByteString -> Builder
B.byteString ByteString
comment forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
B.byteString ByteString
"\n" forall a. Semigroup a => a -> a -> a
<>
Builder
v forall a. Semigroup a => a -> a -> a
<>
if Key
name forall a. Eq a => a -> a -> Bool
== Key
"packages" then Builder
commentedPackages else Builder
"" forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
B.byteString ByteString
"\n"
where
convert :: Value -> Builder
convert Value
v = ByteString -> Builder
B.byteString (forall a. ToJSON a => a -> ByteString
Yaml.encode forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Yaml.object [(Key
name, Value
v)])
nonPresentValue :: a -> Maybe a
nonPresentValue a
"extra-deps" = forall a. a -> Maybe a
Just a
"# extra-deps: []\n"
nonPresentValue a
"flags" = forall a. a -> Maybe a
Just a
"# flags: {}\n"
nonPresentValue a
"extra-package-dbs" = forall a. a -> Maybe a
Just a
"# extra-package-dbs: []\n"
nonPresentValue a
_ = forall a. Maybe a
Nothing
commentLine :: FilePath -> FilePath
commentLine FilePath
l | forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
l = FilePath
"#"
| Bool
otherwise = FilePath
"# " forall a. [a] -> [a] -> [a]
++ FilePath
l
commentHelp :: [FilePath] -> ByteString
commentHelp = FilePath -> ByteString
BC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
commentLine
commentedPackages :: Builder
commentedPackages =
let ignoredComment :: ByteString
ignoredComment = [FilePath] -> ByteString
commentHelp
[ FilePath
"The following packages have been ignored due to incompatibility with the"
, FilePath
"resolver compiler, dependency conflicts with other packages"
, FilePath
"or unsatisfied dependencies."
]
dupComment :: ByteString
dupComment = [FilePath] -> ByteString
commentHelp
[ FilePath
"The following packages have been ignored due to package name conflict "
, FilePath
"with other packages."
]
in ByteString -> [FilePath] -> Builder
commentPackages ByteString
ignoredComment [FilePath]
ignoredPackages
forall a. Semigroup a => a -> a -> a
<> ByteString -> [FilePath] -> Builder
commentPackages ByteString
dupComment [FilePath]
dupPackages
commentPackages :: ByteString -> [FilePath] -> Builder
commentPackages ByteString
comment [FilePath]
pkgs
| [FilePath]
pkgs forall a. Eq a => a -> a -> Bool
/= [] =
ByteString -> Builder
B.byteString ByteString
comment
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
"\n"
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString (FilePath -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> FilePath
"#- " forall a. [a] -> [a] -> [a]
++ FilePath
x forall a. [a] -> [a] -> [a]
++ FilePath
"\n") [FilePath]
pkgs forall a. [a] -> [a] -> [a]
++ [FilePath
"\n"])
| Bool
otherwise = Builder
""
goOthers :: KeyMap v -> Builder
goOthers KeyMap v
o
| forall v. KeyMap v -> Bool
KeyMap.null KeyMap v
o = forall a. Monoid a => a
mempty
| Bool
otherwise = forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Yaml.encode KeyMap v
o
comments :: [(Key, ByteString)]
comments =
[ (Key
"user-message" , ByteString
userMsgHelp)
, (Key
"resolver" , ByteString
resolverHelp)
, (Key
"packages" , ByteString
packageHelp)
, (Key
"extra-deps" , ByteString
extraDepsHelp)
, (Key
"flags" , ByteString
"# Override default flag values for local packages and extra-deps")
, (Key
"extra-package-dbs", ByteString
"# Extra package databases containing global packages")
]
headerHelp :: ByteString
headerHelp = [FilePath] -> ByteString
commentHelp
[ FilePath
"This file was automatically generated by 'stack init'"
, FilePath
""
, FilePath
"Some commonly used options have been documented as comments in this file."
, FilePath
"For advanced use and comprehensive documentation of the format, please see:"
, FilePath
"https://docs.haskellstack.org/en/stable/yaml_configuration/"
]
resolverHelp :: ByteString
resolverHelp = [FilePath] -> ByteString
commentHelp
[ FilePath
"Resolver to choose a 'specific' stackage snapshot or a compiler version."
, FilePath
"A snapshot resolver dictates the compiler version and the set of packages"
, FilePath
"to be used for project dependencies. For example:"
, FilePath
""
, FilePath
"resolver: lts-3.5"
, FilePath
"resolver: nightly-2015-09-21"
, FilePath
"resolver: ghc-7.10.2"
, FilePath
""
, FilePath
"The location of a snapshot can be provided as a file or url. Stack assumes"
, FilePath
"a snapshot provided as a file might change, whereas a url resource does not."
, FilePath
""
, FilePath
"resolver: ./custom-snapshot.yaml"
, FilePath
"resolver: https://example.com/snapshots/2018-01-01.yaml"
]
userMsgHelp :: ByteString
userMsgHelp = [FilePath] -> ByteString
commentHelp
[ FilePath
"A warning or info to be displayed to the user on config load." ]
packageHelp :: ByteString
packageHelp = [FilePath] -> ByteString
commentHelp
[ FilePath
"User packages to be built."
, FilePath
"Various formats can be used as shown in the example below."
, FilePath
""
, FilePath
"packages:"
, FilePath
"- some-directory"
, FilePath
"- https://example.com/foo/bar/baz-0.0.2.tar.gz"
, FilePath
" subdirs:"
, FilePath
" - auto-update"
, FilePath
" - wai"
]
extraDepsHelp :: ByteString
extraDepsHelp = [FilePath] -> ByteString
commentHelp
[ FilePath
"Dependency packages to be pulled from upstream that are not in the resolver."
, FilePath
"These entries can reference officially published versions as well as"
, FilePath
"forks / in-progress versions pinned to a git hash. For example:"
, FilePath
""
, FilePath
"extra-deps:"
, FilePath
"- acme-missiles-0.3"
, FilePath
"- git: https://github.com/commercialhaskell/stack.git"
, FilePath
" commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a"
, FilePath
""
]
footerHelp :: ByteString
footerHelp =
let major :: Version
major = Version -> Version
toMajorVersion forall a b. (a -> b) -> a -> b
$ Version -> Version
C.mkVersion' Version
Meta.version
in [FilePath] -> ByteString
commentHelp
[ FilePath
"Control whether we use the GHC we find on the path"
, FilePath
"system-ghc: true"
, FilePath
""
, FilePath
"Require a specific version of stack, using version ranges"
, FilePath
"require-stack-version: -any # Default"
, FilePath
"require-stack-version: \""
forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
C.display (Version -> VersionRange
C.orLaterVersion Version
major) forall a. [a] -> [a] -> [a]
++ FilePath
"\""
, FilePath
""
, FilePath
"Override the architecture used by stack, especially useful on Windows"
, FilePath
"arch: i386"
, FilePath
"arch: x86_64"
, FilePath
""
, FilePath
"Extra directories used by stack for building"
, FilePath
"extra-include-dirs: [/path/to/dir]"
, FilePath
"extra-lib-dirs: [/path/to/dir]"
, FilePath
""
, FilePath
"Allow a newer minor version of GHC than the snapshot specifies"
, FilePath
"compiler-check: newer-minor"
]
getSnapshots' :: HasConfig env => RIO env Snapshots
getSnapshots' :: forall env. HasConfig env => RIO env Snapshots
getSnapshots' = do
forall env. HasConfig env => RIO env Snapshots
getSnapshots forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Unable to download snapshot list, and therefore could " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"not generate a stack.yaml file automatically"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
Utf8Builder
"This sometimes happens due to missing Certificate Authorities " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"on your system. For more information, see:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
" https://github.com/commercialhaskell/stack/issues/234"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"You can try again, or create your stack.yaml file by hand. See:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
" http://docs.haskellstack.org/en/stable/yaml_configuration/"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Exception was: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
forall (m :: * -> *) a.
(MonadIO m, ?callStack::CallStack) =>
FilePath -> m a
throwString FilePath
""
getDefaultResolver
:: (HasConfig env, HasGHCVariant env)
=> InitOpts
-> Maybe AbstractResolver
-> Map PackageName (ResolvedPath Dir)
-> RIO env
( RawSnapshotLocation
, Map PackageName (Map FlagName Bool)
, Map PackageName Version
, Map PackageName (ResolvedPath Dir))
getDefaultResolver :: forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> Maybe AbstractResolver
-> Map PackageName (ResolvedPath Dir)
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
getDefaultResolver InitOpts
initOpts Maybe AbstractResolver
mresolver Map PackageName (ResolvedPath Dir)
pkgDirs = do
(SnapshotCandidate env
candidate, RawSnapshotLocation
loc) <- case Maybe AbstractResolver
mresolver of
Maybe AbstractResolver
Nothing -> RIO env (SnapshotCandidate env, RawSnapshotLocation)
selectSnapResolver
Just AbstractResolver
ar -> do
RawSnapshotLocation
sl <- forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
ar
SnapshotCandidate env
c <- forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
sl PrintWarnings
NoPrintWarnings Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapshotCandidate env
c, RawSnapshotLocation
sl)
forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> Map PackageName (ResolvedPath Dir)
-> SnapshotCandidate env
-> RawSnapshotLocation
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
getWorkingResolverPlan InitOpts
initOpts Map PackageName (ResolvedPath Dir)
pkgDirs SnapshotCandidate env
candidate RawSnapshotLocation
loc
where
selectSnapResolver :: RIO env (SnapshotCandidate env, RawSnapshotLocation)
selectSnapResolver = do
NonEmpty SnapName
snaps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Snapshots -> NonEmpty SnapName
getRecommendedSnapshots forall env. HasConfig env => RIO env Snapshots
getSnapshots'
(SnapshotCandidate env
c, RawSnapshotLocation
l, BuildPlanCheck
r) <- forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot (forall k a. Map k a -> [a]
Map.elems Map PackageName (ResolvedPath Dir)
pkgDirs) NonEmpty SnapName
snaps
case BuildPlanCheck
r of
BuildPlanCheckFail {} | Bool -> Bool
not (InitOpts -> Bool
omitPackages InitOpts
initOpts)
-> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NonEmpty SnapName -> ConfigException
NoMatchingSnapshot NonEmpty SnapName
snaps)
BuildPlanCheck
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (SnapshotCandidate env
c, RawSnapshotLocation
l)
getWorkingResolverPlan
:: (HasConfig env, HasGHCVariant env)
=> InitOpts
-> Map PackageName (ResolvedPath Dir)
-> SnapshotCandidate env
-> RawSnapshotLocation
-> RIO env
( RawSnapshotLocation
, Map PackageName (Map FlagName Bool)
, Map PackageName Version
, Map PackageName (ResolvedPath Dir))
getWorkingResolverPlan :: forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> Map PackageName (ResolvedPath Dir)
-> SnapshotCandidate env
-> RawSnapshotLocation
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
getWorkingResolverPlan InitOpts
initOpts Map PackageName (ResolvedPath Dir)
pkgDirs0 SnapshotCandidate env
snapCandidate RawSnapshotLocation
snapLoc = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Selected resolver: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapLoc
Map PackageName (ResolvedPath Dir)
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
go Map PackageName (ResolvedPath Dir)
pkgDirs0
where
go :: Map PackageName (ResolvedPath Dir)
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
go Map PackageName (ResolvedPath Dir)
pkgDirs = do
Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
eres <- forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> RawSnapshotLocation
-> SnapshotCandidate env
-> [ResolvedPath Dir]
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
checkBundleResolver InitOpts
initOpts RawSnapshotLocation
snapLoc SnapshotCandidate env
snapCandidate (forall k a. Map k a -> [a]
Map.elems Map PackageName (ResolvedPath Dir)
pkgDirs)
case Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
eres of
Right (Map PackageName (Map FlagName Bool)
f, Map PackageName Version
edeps)-> forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation
snapLoc, Map PackageName (Map FlagName Bool)
f, Map PackageName Version
edeps, Map PackageName (ResolvedPath Dir)
pkgDirs)
Left [PackageName]
ignored
| forall k a. Map k a -> Bool
Map.null Map PackageName (ResolvedPath Dir)
available -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Could not find a working plan for any of " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"the user packages.\nProceeding to create a " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"config anyway."
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation
snapLoc, forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty)
| Bool
otherwise -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Map k a -> Int
Map.size Map PackageName (ResolvedPath Dir)
available forall a. Eq a => a -> a -> Bool
== forall k a. Map k a -> Int
Map.size Map PackageName (ResolvedPath Dir)
pkgDirs) forall a b. (a -> b) -> a -> b
$
forall a. (?callStack::CallStack) => FilePath -> a
error FilePath
"Bug: No packages to ignore"
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
ignored forall a. Ord a => a -> a -> Bool
> Int
1 then do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"*** Ignoring packages:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ Text -> Text
indent forall a b. (a -> b) -> a -> b
$ [FilePath] -> Text
showItems forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageName -> FilePath
packageNameString [PackageName]
ignored
else
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Ignoring package: "
forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString
(case [PackageName]
ignored of
[] -> forall a. (?callStack::CallStack) => FilePath -> a
error FilePath
"getWorkingResolverPlan.head"
PackageName
x:[PackageName]
_ -> PackageName -> FilePath
packageNameString PackageName
x)
Map PackageName (ResolvedPath Dir)
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
go Map PackageName (ResolvedPath Dir)
available
where
indent :: Text -> Text
indent Text
t = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
t)
isAvailable :: PackageName -> ResolvedPath Dir -> Bool
isAvailable PackageName
k ResolvedPath Dir
_ = PackageName
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageName]
ignored
available :: Map PackageName (ResolvedPath Dir)
available = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey PackageName -> ResolvedPath Dir -> Bool
isAvailable Map PackageName (ResolvedPath Dir)
pkgDirs
checkBundleResolver
:: (HasConfig env, HasGHCVariant env)
=> InitOpts
-> RawSnapshotLocation
-> SnapshotCandidate env
-> [ResolvedPath Dir]
-> RIO env
(Either [PackageName] ( Map PackageName (Map FlagName Bool)
, Map PackageName Version))
checkBundleResolver :: forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> RawSnapshotLocation
-> SnapshotCandidate env
-> [ResolvedPath Dir]
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
checkBundleResolver InitOpts
initOpts RawSnapshotLocation
snapshotLoc SnapshotCandidate env
snapCandidate [ResolvedPath Dir]
pkgDirs = do
BuildPlanCheck
result <- forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan [ResolvedPath Dir]
pkgDirs forall a. Maybe a
Nothing SnapshotCandidate env
snapCandidate
case BuildPlanCheck
result of
BuildPlanCheckOk Map PackageName (Map FlagName Bool)
f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Map PackageName (Map FlagName Bool)
f, forall k a. Map k a
Map.empty)
BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
_f DepErrors
e -> do
if InitOpts -> Bool
omitPackages InitOpts
initOpts
then do
BuildPlanCheck -> RIO env ()
warnPartial BuildPlanCheck
result
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"*** Omitting packages with unsatisfied dependencies"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall {k}. Map k DepError -> [PackageName]
failedUserPkgs DepErrors
e
else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> ConfigException
ResolverPartial RawSnapshotLocation
snapshotLoc (forall a. Show a => a -> FilePath
show BuildPlanCheck
result)
BuildPlanCheckFail Map PackageName (Map FlagName Bool)
_ DepErrors
e ActualCompiler
_
| InitOpts -> Bool
omitPackages InitOpts
initOpts -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Resolver compiler mismatch: "
forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapshotLoc
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ Text -> Text
indent forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show BuildPlanCheck
result
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall {k}. Map k DepError -> [PackageName]
failedUserPkgs DepErrors
e
| Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> ConfigException
ResolverMismatch RawSnapshotLocation
snapshotLoc (forall a. Show a => a -> FilePath
show BuildPlanCheck
result)
where
indent :: Text -> Text
indent Text
t = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
t)
warnPartial :: BuildPlanCheck -> RIO env ()
warnPartial BuildPlanCheck
res = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Resolver " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapshotLoc
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" will need external packages: "
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ Text -> Text
indent forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show BuildPlanCheck
res
failedUserPkgs :: Map k DepError -> [PackageName]
failedUserPkgs Map k DepError
e = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall k a. Map k a -> [a]
Map.elems (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy Map k DepError
e))
getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName
getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName
getRecommendedSnapshots Snapshots
snapshots =
case forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [SnapName]
supportedLtss of
Just (SnapName
mostRecent :| [SnapName]
older)
-> SnapName
mostRecent forall a. a -> [a] -> NonEmpty a
:| (SnapName
nightly forall a. a -> [a] -> [a]
: [SnapName]
older)
Maybe (NonEmpty SnapName)
Nothing
-> SnapName
nightly forall a. a -> [a] -> NonEmpty a
:| []
where
ltss :: [SnapName]
ltss = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> SnapName
LTS) (forall a. IntMap a -> [(Int, a)]
IntMap.toDescList forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots)
supportedLtss :: [SnapName]
supportedLtss = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
>= SnapName
minSupportedLts) [SnapName]
ltss
nightly :: SnapName
nightly = Day -> SnapName
Nightly (Snapshots -> Day
snapshotsNightly Snapshots
snapshots)
minSupportedLts :: SnapName
minSupportedLts :: SnapName
minSupportedLts = Int -> Int -> SnapName
LTS Int
3 Int
0
data InitOpts = InitOpts
{ InitOpts -> [Text]
searchDirs :: ![T.Text]
, InitOpts -> Bool
omitPackages :: Bool
, InitOpts -> Bool
forceOverwrite :: Bool
, InitOpts -> Bool
includeSubDirs :: Bool
}
findCabalDirs
:: HasConfig env
=> Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs :: forall env.
HasConfig env =>
Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs Bool
recurse Path Abs Dir
dir =
forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall b t. Path b t -> Path b Dir
parent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Abs Dir
-> (Path Abs File -> Bool)
-> (Path Abs Dir -> Bool)
-> IO [Path Abs File]
findFiles Path Abs Dir
dir forall {b}. Path b File -> Bool
isHpackOrCabal Path Abs Dir -> Bool
subdirFilter)
where
subdirFilter :: Path Abs Dir -> Bool
subdirFilter Path Abs Dir
subdir = Bool
recurse Bool -> Bool -> Bool
&& Bool -> Bool
not (forall {b}. Path b Dir -> Bool
isIgnored Path Abs Dir
subdir)
isHpack :: Path b File -> Bool
isHpack = (forall a. Eq a => a -> a -> Bool
== FilePath
"package.yaml") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename
isCabal :: Path b t -> Bool
isCabal = (FilePath
".cabal" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath
isHpackOrCabal :: Path b File -> Bool
isHpackOrCabal Path b File
x = forall {b}. Path b File -> Bool
isHpack Path b File
x Bool -> Bool -> Bool
|| forall {b} {t}. Path b t -> Bool
isCabal Path b File
x
isIgnored :: Path b Dir -> Bool
isIgnored Path b Dir
path = FilePath
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
dirName Bool -> Bool -> Bool
|| FilePath
dirName forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
ignoredDirs
where
dirName :: FilePath
dirName = FilePath -> FilePath
FP.dropTrailingPathSeparator (forall b t. Path b t -> FilePath
toFilePath (forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
path))
ignoredDirs :: Set FilePath
ignoredDirs :: Set FilePath
ignoredDirs = forall a. Ord a => [a] -> Set a
Set.fromList
[ FilePath
"dist"
]
cabalPackagesCheck
:: (HasConfig env, HasGHCVariant env)
=> [Path Abs Dir]
-> Maybe String
-> RIO env
( Map PackageName (Path Abs File, C.GenericPackageDescription)
, [Path Abs File])
cabalPackagesCheck :: forall env.
(HasConfig env, HasGHCVariant env) =>
[Path Abs Dir]
-> Maybe FilePath
-> RIO
env
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
cabalPackagesCheck [Path Abs Dir]
cabaldirs Maybe FilePath
dupErrMsg = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
cabaldirs) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"We didn't find any local package directories"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"You may want to create a package with \"stack new\" instead"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Create an empty project for now"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"If this isn't what you want, please delete the generated \"stack.yaml\""
[FilePath]
relpaths <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) r t.
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) =>
Path r t -> m FilePath
prettyPath [Path Abs Dir]
cabaldirs
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Using cabal packages:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ [FilePath] -> Utf8Builder
formatGroup [FilePath]
relpaths
[(Path Abs File, GenericPackageDescription)]
packages <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Path Abs Dir]
cabaldirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
cabalfp) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath Path Abs Dir
dir
GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File
cabalfp, GenericPackageDescription
gpd)
let normalizeString :: FilePath -> FilePath
normalizeString = Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizationMode -> Text -> Text
T.normalize NormalizationMode
T.NFC forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
getNameMismatchPkg :: (Path b t, GenericPackageDescription) -> Maybe (Path b t)
getNameMismatchPkg (Path b t
fp, GenericPackageDescription
gpd)
| (FilePath -> FilePath
normalizeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageName
gpdPackageName) GenericPackageDescription
gpd forall a. Eq a => a -> a -> Bool
/= (FilePath -> FilePath
normalizeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath) Path b t
fp
= forall a. a -> Maybe a
Just Path b t
fp
| Bool
otherwise = forall a. Maybe a
Nothing
nameMismatchPkgs :: [Path Abs File]
nameMismatchPkgs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b} {t}.
(Path b t, GenericPackageDescription) -> Maybe (Path b t)
getNameMismatchPkg [(Path Abs File, GenericPackageDescription)]
packages
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs File]
nameMismatchPkgs forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ do
[FilePath]
rels <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) r t.
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) =>
Path r t -> m FilePath
prettyPath [Path Abs File]
nameMismatchPkgs
forall a. (?callStack::CallStack) => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Package name as defined in the .cabal file must match the " forall a. Semigroup a => a -> a -> a
<>
FilePath
".cabal file name.\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"Please fix the following packages and try again:\n"
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Utf8Builder -> Text
utf8BuilderToText ([FilePath] -> Utf8Builder
formatGroup [FilePath]
rels))
let dupGroups :: [(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupSortOn (GenericPackageDescription -> PackageName
gpdPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
dupAll :: [(Path Abs File, GenericPackageDescription)]
dupAll = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall {a}.
[(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups [(Path Abs File, GenericPackageDescription)]
packages
pathlen :: (Path b t, b) -> Int
pathlen = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
getmin :: [(Path b t, b)] -> (Path b t, b)
getmin = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {b} {t} {b}. (Path b t, b) -> Int
pathlen)
dupSelected :: [(Path Abs File, GenericPackageDescription)]
dupSelected = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {t} {b}. [(Path b t, b)] -> (Path b t, b)
getmin (forall {a}.
[(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups [(Path Abs File, GenericPackageDescription)]
packages)
dupIgnored :: [(Path Abs File, GenericPackageDescription)]
dupIgnored = [(Path Abs File, GenericPackageDescription)]
dupAll forall a. Eq a => [a] -> [a] -> [a]
\\ [(Path Abs File, GenericPackageDescription)]
dupSelected
unique :: [(Path Abs File, GenericPackageDescription)]
unique = [(Path Abs File, GenericPackageDescription)]
packages forall a. Eq a => [a] -> [a] -> [a]
\\ [(Path Abs File, GenericPackageDescription)]
dupIgnored
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Path Abs File, GenericPackageDescription)]
dupIgnored forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$ do
[[FilePath]]
dups <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) r t.
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) =>
Path r t -> m FilePath
prettyPathforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)) (forall {a}.
[(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups [(Path Abs File, GenericPackageDescription)]
packages)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Following packages have duplicate package names:\n" forall a. Semigroup a => a -> a -> a
<>
forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Utf8Builder
"\n" (forall a b. (a -> b) -> [a] -> [b]
map [FilePath] -> Utf8Builder
formatGroup [[FilePath]]
dups))
case Maybe FilePath
dupErrMsg of
Maybe FilePath
Nothing -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Packages with duplicate names will be ignored.\n"
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Packages in upper level directories will be preferred.\n"
Just FilePath
msg -> forall a. (?callStack::CallStack) => FilePath -> a
error FilePath
msg
forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
file, GenericPackageDescription
gpd) -> (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd,(Path Abs File
file, GenericPackageDescription
gpd))) [(Path Abs File, GenericPackageDescription)]
unique
, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Path Abs File, GenericPackageDescription)]
dupIgnored)
formatGroup :: [String] -> Utf8Builder
formatGroup :: [FilePath] -> Utf8Builder
formatGroup = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\FilePath
path -> Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
path forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n")
prettyPath ::
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))
=> Path r t
-> m FilePath
prettyPath :: forall (m :: * -> *) r t.
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) =>
Path r t -> m FilePath
prettyPath Path r t
path = do
Either PathException (Path Rel t)
eres <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
makeRelativeToCurrentDir Path r t
path
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either PathException (Path Rel t)
eres of
Left (PathException
_ :: PathException) -> forall b t. Path b t -> FilePath
toFilePath Path r t
path
Right Path Rel t
res -> forall b t. Path b t -> FilePath
toFilePath Path Rel t
res