{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Stack.Init
( initProject
, InitOpts (..)
) where
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.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 RIO.FilePath as FP
import RIO.List ( (\\), intercalate, isSuffixOf, isPrefixOf )
import RIO.List.Partial ( minimumBy )
import Stack.BuildPlan
import Stack.Config ( getSnapshots, makeConcreteResolver )
import Stack.Constants
import Stack.Prelude
import Stack.SourceMap
import Stack.Types.Config
import Stack.Types.Resolver
import Stack.Types.Version ( stackMajorVersion )
data InitException
= NoPackagesToIgnoreBug
deriving (Int -> InitException -> ShowS
[InitException] -> ShowS
InitException -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [InitException] -> ShowS
$cshowList :: [InitException] -> ShowS
show :: InitException -> FilePath
$cshow :: InitException -> FilePath
showsPrec :: Int -> InitException -> ShowS
$cshowsPrec :: Int -> InitException -> ShowS
Show, Typeable)
instance Exception InitException where
displayException :: InitException -> FilePath
displayException InitException
NoPackagesToIgnoreBug = FilePath -> ShowS
bugReport FilePath
"[S-2747]"
FilePath
"No packages to ignore."
data InitPrettyException
= SnapshotDownloadFailure SomeException
| ConfigFileAlreadyExists FilePath
| PackageNameInvalid [(Path Abs File, PackageName)]
deriving (Int -> InitPrettyException -> ShowS
[InitPrettyException] -> ShowS
InitPrettyException -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [InitPrettyException] -> ShowS
$cshowList :: [InitPrettyException] -> ShowS
show :: InitPrettyException -> FilePath
$cshow :: InitPrettyException -> FilePath
showsPrec :: Int -> InitPrettyException -> ShowS
$cshowsPrec :: Int -> InitPrettyException -> ShowS
Show, Typeable)
instance Pretty InitPrettyException where
pretty :: InitPrettyException -> StyleDoc
pretty (ConfigFileAlreadyExists FilePath
reldest) =
StyleDoc
"[S-8009]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Stack declined to create a project-level YAML configuration \
\file."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"The file"
, Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString FilePath
reldest)
, StyleDoc
"already exists. To overwrite it, pass the flag"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--force" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
pretty (PackageNameInvalid [(Path Abs File, PackageName)]
rels) =
StyleDoc
"[S-5267]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Stack did not create project-level YAML configuration, as \
\(like Hackage) it requires a Cabal file name to match the \
\package it defines."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Please rename the following Cabal files:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
( forall a b. (a -> b) -> [a] -> [b]
map
( \(Path Abs File
fp, PackageName
name) -> [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
File (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp)
, StyleDoc
"as"
, Style -> StyleDoc -> StyleDoc
style
Style
File
(forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
".cabal")
]
)
[(Path Abs File, PackageName)]
rels
)
pretty (SnapshotDownloadFailure SomeException
e) =
StyleDoc
"[S-8332]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Stack failed to create project-level YAML configuration, as \
\it was unable to download the index of available snapshots."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"This sometimes happens because Certificate Authorities \
\are missing on your system. You can try the Stack command \
\again or manually create the configuration file. For help \
\about the content of Stack's YAML configuration files, \
\see (for the most recent release of Stack)"
, Style -> StyleDoc -> StyleDoc
style
Style
Url
StyleDoc
"http://docs.haskellstack.org/en/stable/yaml_configuration/"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"While downloading the snapshot index, Stack encountered the \
\following error:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
string (forall e. Exception e => e -> FilePath
displayException SomeException
e)
instance Exception InitPrettyException
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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ FilePath -> InitPrettyException
ConfigFileAlreadyExists FilePath
reldest
[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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Looking for Cabal or"
, Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"package.yaml"
, FilePath -> StyleDoc
flow FilePath
"files to use to initialise Stack's project-level YAML \
\configuration file."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
[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]
-> RIO
env
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
cabalPackagesCheck [Path Abs Dir]
cabaldirs
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
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Initialising Stack's project-level YAML configuration file \
\using snapshot"
, forall a. Pretty a => a -> StyleDoc
pretty (RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
snapshotLoc) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
let n :: Int
n = 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
in [StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"Considered"
, forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Int
n
, StyleDoc
"user"
, if Int
n forall a. Eq a => a -> a -> Bool
== Int
1 then StyleDoc
"package." else StyleDoc
"packages."
]
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
[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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Ignoring these"
, forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs)
, FilePath -> StyleDoc
flow FilePath
"duplicate packages:"
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) [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
[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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Ignoring these"
, forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show (forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored)
, FilePath -> StyleDoc
flow FilePath
"packages due to dependency conflicts:"
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) [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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show (forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps)
, FilePath -> StyleDoc
flow FilePath
"external dependencies were added."
]
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ if Bool
exists
then FilePath
"Overwriting existing configuration file"
else FilePath
"Writing configuration to"
, Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString FilePath
reldest) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"Stack's project-level YAML configuration file has been \
\initialised."
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 :: ShowS
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 ShowS
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 = [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
stackMajorVersion) 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' = forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
forall env. HasConfig env => RIO env Snapshots
getSnapshots
(\SomeException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ SomeException -> InitPrettyException
SnapshotDownloadFailure SomeException
e)
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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
NonEmpty SnapName -> ConfigPrettyException
NoMatchingSnapshot NonEmpty SnapName
snaps
BuildPlanCheck
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Selected the snapshot"
, forall a. Pretty a => a -> StyleDoc
pretty (RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
snapLoc) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"Could not find a working plan for any of the \
\user packages. Proceeding to create a YAML \
\configuration file anyway."
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InitException
NoPackagesToIgnoreBug
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
ignored forall a. Ord a => a -> a -> Bool
> Int
1
then
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn
( FilePath -> StyleDoc
flow FilePath
"Ignoring the following packages:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
( forall a b. (a -> b) -> [a] -> [b]
map
(forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString)
[PackageName]
ignored
)
)
else
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn
( [StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Ignoring package:"
, forall a. IsString a => FilePath -> a
fromString
( case [PackageName]
ignored of
[] -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InitException
NoPackagesToIgnoreBug
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
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
RawSnapshotLocation -> FilePath -> ConfigPrettyException
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
ind 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
RawSnapshotLocation -> FilePath -> ConfigPrettyException
ResolverMismatch RawSnapshotLocation
snapshotLoc (forall a. Show a => a -> FilePath
show BuildPlanCheck
result)
where
ind :: Text -> Text
ind 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
ind 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 = ShowS
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]
-> RIO env
( Map PackageName (Path Abs File, C.GenericPackageDescription)
, [Path Abs File])
cabalPackagesCheck :: forall env.
(HasConfig env, HasGHCVariant env) =>
[Path Abs Dir]
-> RIO
env
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
cabalPackagesCheck [Path Abs Dir]
cabaldirs = 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
$
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Stack did not find any local package directories. You may \
\want to create a package with"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (FilePath -> StyleDoc
flow FilePath
"stack new")
, FilePath -> StyleDoc
flow FilePath
"instead."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"Stack will create an empty project. If this is not what \
\you want, please delete the generated"
, Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"stack.yaml"
, StyleDoc
"file."
]
[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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
relpaths) forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"Using the Cabal packages:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) [FilePath]
relpaths)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
[Either
(Path Abs File, PackageName)
(Path Abs File, GenericPackageDescription)]
ePackages <- 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) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
dir
Either PantryException GenericPackageDescription
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 (PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings)
case Either PantryException GenericPackageDescription
eres :: Either PantryException C.GenericPackageDescription of
Right GenericPackageDescription
gpd -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Path Abs File
cabalfp, GenericPackageDescription
gpd)
Left (MismatchedCabalName Path Abs File
fp PackageName
name) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Path Abs File
fp, PackageName
name)
Left PantryException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
e
let ([(Path Abs File, PackageName)]
nameMismatchPkgs, [(Path Abs File, GenericPackageDescription)]
packages) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
(Path Abs File, PackageName)
(Path Abs File, GenericPackageDescription)]
ePackages
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Path Abs File, PackageName)]
nameMismatchPkgs forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ [(Path Abs File, PackageName)] -> InitPrettyException
PackageNameInvalid [(Path Abs File, PackageName)]
nameMismatchPkgs
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 env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"The following packages have duplicate package names:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \[FilePath]
dup -> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => FilePath -> a
fromString [FilePath]
dup)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
)
[[FilePath]]
dups
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Packages with duplicate names will be ignored. Packages \
\in upper level directories will be preferred."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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