{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Init
( initProject
, InitOpts (..)
) where
import Stack.Prelude
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as HM
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 :: 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 Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
FilePath
reldest <- Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Rel File -> FilePath)
-> RIO env (Path Rel File) -> RIO env FilePath
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Path Abs File -> RIO env (RelPath (Path Abs File))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
makeRelativeToCurrentDir Path Abs File
dest
Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (InitOpts -> Bool
forceOverwrite InitOpts
initOpts) Bool -> Bool -> Bool
&& Bool
exists) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
FilePath -> RIO env ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString
(FilePath
"Error: Stack configuration file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
reldest FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
FilePath
" exists, use '--force' to overwrite it.")
[Path Abs Dir]
dirs <- (Text -> RIO env (Path Abs Dir))
-> [Text] -> RIO env [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' (FilePath -> RIO env (Path Abs Dir))
-> (Text -> FilePath) -> Text -> RIO env (Path Abs Dir)
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 = Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
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 [Path Abs Dir] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs then [Path Abs Dir
currDir] else [Path Abs Dir]
dirs
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Looking for .cabal or package.yaml files to use to init the project."
[Path Abs Dir]
cabaldirs <- Set (Path Abs Dir) -> [Path Abs Dir]
forall a. Set a -> [a]
Set.toList (Set (Path Abs Dir) -> [Path Abs Dir])
-> ([Set (Path Abs Dir)] -> Set (Path Abs Dir))
-> [Set (Path Abs Dir)]
-> [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set (Path Abs Dir)] -> Set (Path Abs Dir)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (Path Abs Dir)] -> [Path Abs Dir])
-> RIO env [Set (Path Abs Dir)] -> RIO env [Path Abs Dir]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path Abs Dir -> RIO env (Set (Path Abs Dir)))
-> [Path Abs Dir] -> RIO env [Set (Path Abs Dir)]
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) <- [Path Abs Dir]
-> Maybe FilePath
-> RIO
env
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
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
forall a. Maybe a
Nothing
let makeRelDir :: Path Abs Dir -> FilePath
makeRelDir Path Abs Dir
dir =
case Path Abs Dir -> Path Abs Dir -> Maybe (Path Rel Dir)
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 Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir
dir -> FilePath
"."
| Bool
otherwise -> Bool -> FilePath -> FilePath
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
dir
Just Path Rel Dir
rel -> Path Rel Dir -> FilePath
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 = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp
in RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath (Text -> RelFilePath) -> Text -> RelFilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
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 = ((Path Abs File, GenericPackageDescription) -> ResolvedPath Dir)
-> Map PackageName (Path Abs File, GenericPackageDescription)
-> Map PackageName (ResolvedPath Dir)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Path Abs File -> ResolvedPath Dir
fpToPkgDir (Path Abs File -> ResolvedPath Dir)
-> ((Path Abs File, GenericPackageDescription) -> Path Abs File)
-> (Path Abs File, GenericPackageDescription)
-> ResolvedPath Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File, GenericPackageDescription) -> Path Abs File
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) <- InitOpts
-> Maybe AbstractResolver
-> Map PackageName (ResolvedPath Dir)
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
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 = Map PackageName (Path Abs File, GenericPackageDescription)
-> Map PackageName (ResolvedPath Dir)
-> Map PackageName (Path Abs File, GenericPackageDescription)
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 [Path Abs File] -> [Path Abs File] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] =
FilePath
"Warning (added by new or init): Some packages were found to \
\have names conflicting with others and have been commented \
\out in the packages section.\n"
| Bool
otherwise = FilePath
""
missingPkgMsg :: FilePath
missingPkgMsg
| Map PackageName (Path Abs File, GenericPackageDescription) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
FilePath
"Warning (added by new or init): Some packages were found to \
\be incompatible with the resolver and have been left commented \
\out in the packages section.\n"
| Bool
otherwise = FilePath
""
extraDepMsg :: FilePath
extraDepMsg
| Map PackageName Version -> Int
forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
FilePath
"Warning (added by new or init): Specified resolver could not \
\satisfy all dependencies. Some external packages have been \
\added as dependencies.\n"
| Bool
otherwise = FilePath
""
makeUserMsg :: t FilePath -> FilePath
makeUserMsg t FilePath
msgs =
let msg :: FilePath
msg = t FilePath -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t FilePath
msgs
in if FilePath
msg FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"" then
FilePath
msg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"You can omit this message by removing it from \
\stack.yaml\n"
else FilePath
""
userMsg :: FilePath
userMsg = [FilePath] -> FilePath
forall (t :: * -> *). Foldable t => t FilePath -> FilePath
makeUserMsg [FilePath
dupPkgMsg, FilePath
missingPkgMsg, FilePath
extraDepMsg]
gpdByDir :: Map (Path Abs Dir) GenericPackageDescription
gpdByDir = [(Path Abs Dir, GenericPackageDescription)]
-> Map (Path Abs Dir) GenericPackageDescription
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp, GenericPackageDescription
gpd) | (Path Abs File
fp, GenericPackageDescription
gpd) <- Map PackageName (Path Abs File, GenericPackageDescription)
-> [(Path Abs File, GenericPackageDescription)]
forall k a. Map k a -> [a]
Map.elems Map PackageName (Path Abs File, GenericPackageDescription)
bundle]
gpds :: [GenericPackageDescription]
gpds = Map PackageName GenericPackageDescription
-> [GenericPackageDescription]
forall k a. Map k a -> [a]
Map.elems (Map PackageName GenericPackageDescription
-> [GenericPackageDescription])
-> Map PackageName GenericPackageDescription
-> [GenericPackageDescription]
forall a b. (a -> b) -> a -> b
$
(ResolvedPath Dir -> Maybe GenericPackageDescription)
-> Map PackageName (ResolvedPath Dir)
-> Map PackageName GenericPackageDescription
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((Path Abs Dir
-> Map (Path Abs Dir) GenericPackageDescription
-> Maybe GenericPackageDescription)
-> Map (Path Abs Dir) GenericPackageDescription
-> Path Abs Dir
-> Maybe GenericPackageDescription
forall a b c. (a -> b -> c) -> b -> a -> c
flip Path Abs Dir
-> Map (Path Abs Dir) GenericPackageDescription
-> Maybe GenericPackageDescription
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map (Path Abs Dir) GenericPackageDescription
gpdByDir (Path Abs Dir -> Maybe GenericPackageDescription)
-> (ResolvedPath Dir -> Path Abs Dir)
-> ResolvedPath Dir
-> Maybe GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute) Map PackageName (ResolvedPath Dir)
rbundle
[PackageLocation]
deps <- [(PackageName, Version)]
-> ((PackageName, Version) -> RIO env PackageLocation)
-> RIO env [PackageLocation]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName Version -> [(PackageName, Version)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName Version
extraDeps) (((PackageName, Version) -> RIO env PackageLocation)
-> RIO env [PackageLocation])
-> ((PackageName, Version) -> RIO env PackageLocation)
-> RIO env [PackageLocation]
forall a b. (a -> b) -> a -> b
$ \(PackageName
n, Version
v) ->
PackageLocationImmutable -> PackageLocation
PLImmutable (PackageLocationImmutable -> PackageLocation)
-> (CompletePackageLocation -> PackageLocationImmutable)
-> CompletePackageLocation
-> PackageLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompletePackageLocation -> PackageLocationImmutable
cplComplete (CompletePackageLocation -> PackageLocation)
-> RIO env CompletePackageLocation -> RIO env PackageLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
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) Maybe TreeKey
forall a. Maybe a
Nothing)
let p :: Project
p = Project :: Maybe FilePath
-> [RelFilePath]
-> [RawPackageLocation]
-> Map PackageName (Map FlagName Bool)
-> RawSnapshotLocation
-> Maybe WantedCompiler
-> [FilePath]
-> Maybe Curator
-> Set PackageName
-> Project
Project
{ projectUserMsg :: Maybe FilePath
projectUserMsg = if FilePath
userMsg FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" then Maybe FilePath
forall a. Maybe a
Nothing else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
userMsg
, projectPackages :: [RelFilePath]
projectPackages = ResolvedPath Dir -> RelFilePath
forall t. ResolvedPath t -> RelFilePath
resolvedRelative (ResolvedPath Dir -> RelFilePath)
-> [ResolvedPath Dir] -> [RelFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (ResolvedPath Dir) -> [ResolvedPath Dir]
forall k a. Map k a -> [a]
Map.elems Map PackageName (ResolvedPath Dir)
rbundle
, projectDependencies :: [RawPackageLocation]
projectDependencies = (PackageLocation -> RawPackageLocation)
-> [PackageLocation] -> [RawPackageLocation]
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 = Maybe WantedCompiler
forall a. Maybe a
Nothing
, projectExtraPackageDBs :: [FilePath]
projectExtraPackageDBs = []
, projectCurator :: Maybe Curator
projectCurator = Maybe Curator
forall a. Maybe a
Nothing
, projectDropPackages :: Set PackageName
projectDropPackages = Set PackageName
forall a. Monoid a => a
mempty
}
makeRel :: Path Abs File -> RIO env FilePath
makeRel = (Path Rel File -> FilePath)
-> RIO env (Path Rel File) -> RIO env FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (RIO env (Path Rel File) -> RIO env FilePath)
-> (Path Abs File -> RIO env (Path Rel File))
-> Path Abs File
-> RIO env FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> RIO env (Path Rel File)
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
makeRelativeToCurrentDir
indent :: Text -> Text
indent Text
t = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
t)
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Initialising configuration using resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapshotLoc
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Total number of user packages considered: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Map PackageName (Path Abs File, GenericPackageDescription) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
bundle Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Path Abs File] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs File]
dupPkgs [Path Abs File] -> [Path Abs File] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning! Ignoring "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow ([Path Abs File] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" duplicate packages:"
[FilePath]
rels <- (Path Abs File -> RIO env FilePath)
-> [Path Abs File] -> RIO env [FilePath]
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
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Text
showItems [FilePath]
rels
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map PackageName (Path Abs File, GenericPackageDescription) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning! Ignoring "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Map PackageName (Path Abs File, GenericPackageDescription) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" packages due to dependency conflicts:"
[FilePath]
rels <- (Path Abs File -> RIO env FilePath)
-> [Path Abs File] -> RIO env [FilePath]
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 (Map PackageName (Path Abs File) -> [Path Abs File]
forall k a. Map k a -> [a]
Map.elems (((Path Abs File, GenericPackageDescription) -> Path Abs File)
-> Map PackageName (Path Abs File, GenericPackageDescription)
-> Map PackageName (Path Abs File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs File, GenericPackageDescription) -> Path Abs File
forall a b. (a, b) -> a
fst Map PackageName (Path Abs File, GenericPackageDescription)
ignored))
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Text
showItems [FilePath]
rels
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map PackageName Version -> Int
forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warning! " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Map PackageName Version -> Int
forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" external dependencies were added."
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
(if Bool
exists then Utf8Builder
"Overwriting existing configuration file: "
else Utf8Builder
"Writing configuration to file: ")
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
reldest
Path Abs File -> Builder -> RIO env ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
dest
(Builder -> RIO env ()) -> Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Project -> [FilePath] -> [FilePath] -> Builder
renderStackYaml Project
p
(Map PackageName FilePath -> [FilePath]
forall k a. Map k a -> [a]
Map.elems (Map PackageName FilePath -> [FilePath])
-> Map PackageName FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ((Path Abs File, GenericPackageDescription) -> FilePath)
-> Map PackageName (Path Abs File, GenericPackageDescription)
-> Map PackageName FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir -> FilePath
makeRelDir (Path Abs Dir -> FilePath)
-> ((Path Abs File, GenericPackageDescription) -> Path Abs Dir)
-> (Path Abs File, GenericPackageDescription)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir)
-> ((Path Abs File, GenericPackageDescription) -> Path Abs File)
-> (Path Abs File, GenericPackageDescription)
-> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File, GenericPackageDescription) -> Path Abs File
forall a b. (a, b) -> a
fst) Map PackageName (Path Abs File, GenericPackageDescription)
ignored)
((Path Abs File -> FilePath) -> [Path Abs File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs Dir -> FilePath
makeRelDir (Path Abs Dir -> FilePath)
-> (Path Abs File -> Path Abs Dir) -> Path Abs File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent) [Path Abs File]
dupPkgs)
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
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 Project -> Value
forall a. ToJSON a => a -> Value
Yaml.toJSON Project
p of
Yaml.Object Object
o -> Object -> Builder
renderObject Object
o
Value
_ -> Bool -> Builder -> Builder
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Project -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Project
p
where
renderObject :: Object -> Builder
renderObject Object
o =
ByteString -> Builder
B.byteString ByteString
headerHelp
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
"\n\n"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Text, ByteString) -> Builder) -> [(Text, ByteString)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (Object -> (Text, ByteString) -> Builder
goComment Object
o) [(Text, ByteString)]
comments
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Object -> Builder
forall v k. (ToJSON v, ToJSONKey k) => HashMap k v -> Builder
goOthers (Object
o Object -> HashMap Text ByteString -> Object
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
`HM.difference` [(Text, ByteString)] -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, ByteString)]
comments)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
footerHelp
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
goComment :: Object -> (Text, ByteString) -> Builder
goComment Object
o (Text
name, ByteString
comment) =
case (Value -> Builder
convert (Value -> Builder) -> Maybe Value -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
name Object
o) Maybe Builder -> Maybe Builder -> Maybe Builder
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Builder
forall a a. (Eq a, IsString a, IsString a) => a -> Maybe a
nonPresentValue Text
name of
Maybe Builder
Nothing -> Bool -> Builder -> Builder
forall a. HasCallStack => Bool -> a -> a
assert (Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"user-message") Builder
forall a. Monoid a => a
mempty
Just Builder
v ->
ByteString -> Builder
B.byteString ByteString
comment Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
B.byteString ByteString
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Builder
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
if Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"packages" then Builder
commentedPackages else Builder
"" Builder -> Builder -> 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 (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Yaml.object [(Text
name, Value
v)])
nonPresentValue :: a -> Maybe a
nonPresentValue a
"extra-deps" = a -> Maybe a
forall a. a -> Maybe a
Just a
"# extra-deps: []\n"
nonPresentValue a
"flags" = a -> Maybe a
forall a. a -> Maybe a
Just a
"# flags: {}\n"
nonPresentValue a
"extra-package-dbs" = a -> Maybe a
forall a. a -> Maybe a
Just a
"# extra-package-dbs: []\n"
nonPresentValue a
_ = Maybe a
forall a. Maybe a
Nothing
commentLine :: FilePath -> FilePath
commentLine FilePath
l | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
l = FilePath
"#"
| Bool
otherwise = FilePath
"# " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l
commentHelp :: [FilePath] -> ByteString
commentHelp = FilePath -> ByteString
BC.pack (FilePath -> ByteString)
-> ([FilePath] -> FilePath) -> [FilePath] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" ([FilePath] -> FilePath)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
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
Builder -> Builder -> Builder
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 [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] =
ByteString -> Builder
B.byteString ByteString
comment
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
"\n"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString (FilePath -> ByteString
BC.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> FilePath
"#- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n") [FilePath]
pkgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"\n"])
| Bool
otherwise = Builder
""
goOthers :: HashMap k v -> Builder
goOthers HashMap k v
o
| HashMap k v -> Bool
forall k v. HashMap k v -> Bool
HM.null HashMap k v
o = Builder
forall a. Monoid a => a
mempty
| Bool
otherwise = Bool -> Builder -> Builder
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ HashMap k v -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode HashMap k v
o
comments :: [(Text, ByteString)]
comments =
[ (Text
"user-message" , ByteString
userMsgHelp)
, (Text
"resolver" , ByteString
resolverHelp)
, (Text
"packages" , ByteString
packageHelp)
, (Text
"extra-deps" , ByteString
extraDepsHelp)
, (Text
"flags" , ByteString
"# Override default flag values for local packages and extra-deps")
, (Text
"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 (Version -> Version) -> Version -> Version
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: \""
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ VersionRange -> FilePath
forall a. Pretty a => a -> FilePath
C.display (Version -> VersionRange
C.orLaterVersion Version
major) FilePath -> FilePath -> FilePath
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' :: RIO env Snapshots
getSnapshots' = do
RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots RIO env Snapshots
-> (SomeException -> RIO env Snapshots) -> RIO env Snapshots
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Unable to download snapshot list, and therefore could " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"not generate a stack.yaml file automatically"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"This sometimes happens due to missing Certificate Authorities " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"on your system. For more information, see:"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
" https://github.com/commercialhaskell/stack/issues/234"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"You can try again, or create your stack.yaml file by hand. See:"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
" http://docs.haskellstack.org/en/stable/yaml_configuration/"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
""
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Exception was: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
FilePath -> RIO env Snapshots
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
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 :: 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 <- AbstractResolver -> RIO env RawSnapshotLocation
forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
ar
SnapshotCandidate env
c <- RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
sl PrintWarnings
NoPrintWarnings Bool
False
(SnapshotCandidate env, RawSnapshotLocation)
-> RIO env (SnapshotCandidate env, RawSnapshotLocation)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapshotCandidate env
c, RawSnapshotLocation
sl)
InitOpts
-> Map PackageName (ResolvedPath Dir)
-> SnapshotCandidate env
-> RawSnapshotLocation
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
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 <- (Snapshots -> NonEmpty SnapName)
-> RIO env Snapshots -> RIO env (NonEmpty SnapName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Snapshots -> NonEmpty SnapName
getRecommendedSnapshots RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots'
(SnapshotCandidate env
c, RawSnapshotLocation
l, BuildPlanCheck
r) <- [ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot (Map PackageName (ResolvedPath Dir) -> [ResolvedPath Dir]
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)
-> ConfigException
-> RIO env (SnapshotCandidate env, RawSnapshotLocation)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NonEmpty SnapName -> ConfigException
NoMatchingSnapshot NonEmpty SnapName
snaps)
BuildPlanCheck
_ -> (SnapshotCandidate env, RawSnapshotLocation)
-> RIO env (SnapshotCandidate env, RawSnapshotLocation)
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 :: 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
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Selected resolver: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
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 <- InitOpts
-> RawSnapshotLocation
-> SnapshotCandidate env
-> [ResolvedPath Dir]
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
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 (Map PackageName (ResolvedPath Dir) -> [ResolvedPath Dir]
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)-> (RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
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
| Map PackageName (ResolvedPath Dir) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (ResolvedPath Dir)
available -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"*** Could not find a working plan for any of \
\the user packages.\nProceeding to create a \
\config anyway."
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
-> RIO
env
(RawSnapshotLocation, Map PackageName (Map FlagName Bool),
Map PackageName Version, Map PackageName (ResolvedPath Dir))
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSnapshotLocation
snapLoc, Map PackageName (Map FlagName Bool)
forall k a. Map k a
Map.empty, Map PackageName Version
forall k a. Map k a
Map.empty, Map PackageName (ResolvedPath Dir)
forall k a. Map k a
Map.empty)
| Bool
otherwise -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map PackageName (ResolvedPath Dir) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (ResolvedPath Dir)
available Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map PackageName (ResolvedPath Dir) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (ResolvedPath Dir)
pkgDirs) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
FilePath -> RIO env ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Bug: No packages to ignore"
if [PackageName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
ignored Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"*** Ignoring packages:"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Text
showItems ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ (PackageName -> FilePath) -> [PackageName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> FilePath
packageNameString [PackageName]
ignored
else
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Ignoring package: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString
(case [PackageName]
ignored of
[] -> FilePath -> FilePath
forall a. HasCallStack => 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 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " Text -> Text -> 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 PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageName]
ignored
available :: Map PackageName (ResolvedPath Dir)
available = (PackageName -> ResolvedPath Dir -> Bool)
-> Map PackageName (ResolvedPath Dir)
-> Map PackageName (ResolvedPath Dir)
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 :: 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 <- [ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan [ResolvedPath Dir]
pkgDirs Maybe (Map PackageName (Map FlagName Bool))
forall a. Maybe a
Nothing SnapshotCandidate env
snapCandidate
case BuildPlanCheck
result of
BuildPlanCheckOk Map PackageName (Map FlagName Bool)
f -> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ (Map PackageName (Map FlagName Bool), Map PackageName Version)
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
forall a b. b -> Either a b
Right (Map PackageName (Map FlagName Bool)
f, Map PackageName Version
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
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"*** Omitting packages with unsatisfied dependencies"
Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ [PackageName]
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
forall a b. a -> Either a b
Left ([PackageName]
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
-> [PackageName]
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
forall a b. (a -> b) -> a -> b
$ DepErrors -> [PackageName]
forall k. Map k DepError -> [PackageName]
failedUserPkgs DepErrors
e
else ConfigException
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ConfigException
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> ConfigException
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> ConfigException
ResolverPartial RawSnapshotLocation
snapshotLoc (BuildPlanCheck -> FilePath
forall a. Show a => a -> FilePath
show BuildPlanCheck
result)
BuildPlanCheckFail Map PackageName (Map FlagName Bool)
_ DepErrors
e ActualCompiler
_
| InitOpts -> Bool
omitPackages InitOpts
initOpts -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Resolver compiler mismatch: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapshotLoc
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ BuildPlanCheck -> FilePath
forall a. Show a => a -> FilePath
show BuildPlanCheck
result
Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ [PackageName]
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
forall a b. a -> Either a b
Left ([PackageName]
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
-> [PackageName]
-> Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)
forall a b. (a -> b) -> a -> b
$ DepErrors -> [PackageName]
forall k. Map k DepError -> [PackageName]
failedUserPkgs DepErrors
e
| Bool
otherwise -> ConfigException
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ConfigException
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> ConfigException
-> RIO
env
(Either
[PackageName]
(Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> ConfigException
ResolverMismatch RawSnapshotLocation
snapshotLoc (BuildPlanCheck -> FilePath
forall a. Show a => a -> FilePath
show BuildPlanCheck
result)
where
indent :: Text -> Text
indent Text
t = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
t)
warnPartial :: BuildPlanCheck -> RIO env ()
warnPartial BuildPlanCheck
res = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"*** Resolver " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
snapshotLoc
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" will need external packages: "
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ BuildPlanCheck -> FilePath
forall a. Show a => a -> FilePath
show BuildPlanCheck
res
failedUserPkgs :: Map k DepError -> [PackageName]
failedUserPkgs Map k DepError
e = Map PackageName VersionRange -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (Map PackageName VersionRange -> [PackageName])
-> Map PackageName VersionRange -> [PackageName]
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map k (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> Map k DepError -> Map k (Map PackageName VersionRange)
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 [SnapName] -> Maybe (NonEmpty SnapName)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [SnapName]
ltss of
Just (SnapName
mostRecent :| [SnapName]
older)
-> SnapName
mostRecent SnapName -> [SnapName] -> NonEmpty SnapName
forall a. a -> [a] -> NonEmpty a
:| (SnapName
nightly SnapName -> [SnapName] -> [SnapName]
forall a. a -> [a] -> [a]
: [SnapName]
older)
Maybe (NonEmpty SnapName)
Nothing
-> SnapName
nightly SnapName -> [SnapName] -> NonEmpty SnapName
forall a. a -> [a] -> NonEmpty a
:| []
where
ltss :: [SnapName]
ltss = ((Int, Int) -> SnapName) -> [(Int, Int)] -> [SnapName]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> SnapName) -> (Int, Int) -> SnapName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> SnapName
LTS) (IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IntMap.toDescList (IntMap Int -> [(Int, Int)]) -> IntMap Int -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Snapshots -> IntMap Int
snapshotsLts Snapshots
snapshots)
nightly :: SnapName
nightly = Day -> SnapName
Nightly (Snapshots -> Day
snapshotsNightly Snapshots
snapshots)
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 :: Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs Bool
recurse Path Abs Dir
dir =
[Path Abs Dir] -> Set (Path Abs Dir)
forall a. Ord a => [a] -> Set a
Set.fromList ([Path Abs Dir] -> Set (Path Abs Dir))
-> ([Path Abs File] -> [Path Abs Dir])
-> [Path Abs File]
-> Set (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File -> Path Abs Dir)
-> [Path Abs File] -> [Path Abs Dir]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent
([Path Abs File] -> Set (Path Abs Dir))
-> RIO env [Path Abs File] -> RIO env (Set (Path Abs Dir))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Path Abs File] -> RIO env [Path Abs File]
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 Path Abs File -> Bool
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 (Path Abs Dir -> Bool
forall b. Path b Dir -> Bool
isIgnored Path Abs Dir
subdir)
isHpack :: Path b File -> Bool
isHpack = (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"package.yaml") (FilePath -> Bool)
-> (Path b File -> FilePath) -> Path b File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Rel File -> FilePath)
-> (Path b File -> Path Rel File) -> Path b File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b File -> Path Rel File
forall b. Path b File -> Path Rel File
filename
isCabal :: Path b t -> Bool
isCabal = (FilePath
".cabal" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) (FilePath -> Bool) -> (Path b t -> FilePath) -> Path b t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath
isHpackOrCabal :: Path b File -> Bool
isHpackOrCabal Path b File
x = Path b File -> Bool
forall b. Path b File -> Bool
isHpack Path b File
x Bool -> Bool -> Bool
|| Path b File -> Bool
forall b t. Path b t -> Bool
isCabal Path b File
x
isIgnored :: Path b Dir -> Bool
isIgnored Path b Dir
path = FilePath
"." FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
dirName Bool -> Bool -> Bool
|| FilePath
dirName FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
ignoredDirs
where
dirName :: FilePath
dirName = FilePath -> FilePath
FP.dropTrailingPathSeparator (Path Rel Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path b Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
path))
ignoredDirs :: Set FilePath
ignoredDirs :: Set FilePath
ignoredDirs = [FilePath] -> Set FilePath
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 :: [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
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs Dir] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
cabaldirs) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"We didn't find any local package directories"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"You may want to create a package with \"stack new\" instead"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Create an empty project for now"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"If this isn't what you want, please delete the generated \"stack.yaml\""
[FilePath]
relpaths <- (Path Abs Dir -> RIO env FilePath)
-> [Path Abs Dir] -> RIO env [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs Dir -> RIO env FilePath
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
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Using cabal packages:"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Utf8Builder
formatGroup [FilePath]
relpaths
[(Path Abs File, GenericPackageDescription)]
packages <- [Path Abs Dir]
-> (Path Abs Dir
-> RIO env (Path Abs File, GenericPackageDescription))
-> RIO env [(Path Abs File, GenericPackageDescription)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Path Abs Dir]
cabaldirs ((Path Abs Dir
-> RIO env (Path Abs File, GenericPackageDescription))
-> RIO env [(Path Abs File, GenericPackageDescription)])
-> (Path Abs Dir
-> RIO env (Path Abs File, GenericPackageDescription))
-> RIO env [(Path Abs File, GenericPackageDescription)]
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
cabalfp) <- Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
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 <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
(Path Abs File, GenericPackageDescription)
-> RIO env (Path Abs File, GenericPackageDescription)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File
cabalfp, GenericPackageDescription
gpd)
let normalizeString :: FilePath -> FilePath
normalizeString = Text -> FilePath
T.unpack (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizationMode -> Text -> Text
T.normalize NormalizationMode
T.NFC (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
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 (FilePath -> FilePath)
-> (GenericPackageDescription -> FilePath)
-> GenericPackageDescription
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString (PackageName -> FilePath)
-> (GenericPackageDescription -> PackageName)
-> GenericPackageDescription
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageName
gpdPackageName) GenericPackageDescription
gpd FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= (FilePath -> FilePath
normalizeString (FilePath -> FilePath)
-> (Path b t -> FilePath) -> Path b t -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.takeBaseName (FilePath -> FilePath)
-> (Path b t -> FilePath) -> Path b t -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath) Path b t
fp
= Path b t -> Maybe (Path b t)
forall a. a -> Maybe a
Just Path b t
fp
| Bool
otherwise = Maybe (Path b t)
forall a. Maybe a
Nothing
nameMismatchPkgs :: [Path Abs File]
nameMismatchPkgs = ((Path Abs File, GenericPackageDescription)
-> Maybe (Path Abs File))
-> [(Path Abs File, GenericPackageDescription)] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Path Abs File, GenericPackageDescription) -> Maybe (Path Abs File)
forall b t.
(Path b t, GenericPackageDescription) -> Maybe (Path b t)
getNameMismatchPkg [(Path Abs File, GenericPackageDescription)]
packages
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs File]
nameMismatchPkgs [Path Abs File] -> [Path Abs File] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
[FilePath]
rels <- (Path Abs File -> RIO env FilePath)
-> [Path Abs File] -> RIO env [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Path Abs File -> RIO env FilePath
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
FilePath -> RIO env ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Package name as defined in the .cabal file must match the \
\.cabal file name.\n\
\Please fix the following packages and try again:\n"
FilePath -> FilePath -> FilePath
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 = ([(a, GenericPackageDescription)] -> Bool)
-> [[(a, GenericPackageDescription)]]
-> [[(a, GenericPackageDescription)]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool)
-> ([(a, GenericPackageDescription)] -> Int)
-> [(a, GenericPackageDescription)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, GenericPackageDescription)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
([[(a, GenericPackageDescription)]]
-> [[(a, GenericPackageDescription)]])
-> ([(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]])
-> [(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, GenericPackageDescription) -> PackageName)
-> [(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupSortOn (GenericPackageDescription -> PackageName
gpdPackageName (GenericPackageDescription -> PackageName)
-> ((a, GenericPackageDescription) -> GenericPackageDescription)
-> (a, GenericPackageDescription)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, GenericPackageDescription) -> GenericPackageDescription
forall a b. (a, b) -> b
snd)
dupAll :: [(Path Abs File, GenericPackageDescription)]
dupAll = [[(Path Abs File, GenericPackageDescription)]]
-> [(Path Abs File, GenericPackageDescription)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Path Abs File, GenericPackageDescription)]]
-> [(Path Abs File, GenericPackageDescription)])
-> [[(Path Abs File, GenericPackageDescription)]]
-> [(Path Abs File, GenericPackageDescription)]
forall a b. (a -> b) -> a -> b
$ [(Path Abs File, GenericPackageDescription)]
-> [[(Path Abs File, GenericPackageDescription)]]
forall a.
[(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups [(Path Abs File, GenericPackageDescription)]
packages
pathlen :: (Path b t, b) -> Int
pathlen = [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FilePath] -> Int)
-> ((Path b t, b) -> [FilePath]) -> (Path b t, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitPath (FilePath -> [FilePath])
-> ((Path b t, b) -> FilePath) -> (Path b t, b) -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path b t -> FilePath)
-> ((Path b t, b) -> Path b t) -> (Path b t, b) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path b t, b) -> Path b t
forall a b. (a, b) -> a
fst
getmin :: [(Path b t, b)] -> (Path b t, b)
getmin = ((Path b t, b) -> (Path b t, b) -> Ordering)
-> [(Path b t, b)] -> (Path b t, b)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Path b t, b) -> Int)
-> (Path b t, b)
-> (Path b t, b)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Path b t, b) -> Int
forall b t b. (Path b t, b) -> Int
pathlen)
dupSelected :: [(Path Abs File, GenericPackageDescription)]
dupSelected = ([(Path Abs File, GenericPackageDescription)]
-> (Path Abs File, GenericPackageDescription))
-> [[(Path Abs File, GenericPackageDescription)]]
-> [(Path Abs File, GenericPackageDescription)]
forall a b. (a -> b) -> [a] -> [b]
map [(Path Abs File, GenericPackageDescription)]
-> (Path Abs File, GenericPackageDescription)
forall b t b. [(Path b t, b)] -> (Path b t, b)
getmin ([(Path Abs File, GenericPackageDescription)]
-> [[(Path Abs File, GenericPackageDescription)]]
forall a.
[(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups [(Path Abs File, GenericPackageDescription)]
packages)
dupIgnored :: [(Path Abs File, GenericPackageDescription)]
dupIgnored = [(Path Abs File, GenericPackageDescription)]
dupAll [(Path Abs File, GenericPackageDescription)]
-> [(Path Abs File, GenericPackageDescription)]
-> [(Path Abs File, GenericPackageDescription)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Path Abs File, GenericPackageDescription)]
dupSelected
unique :: [(Path Abs File, GenericPackageDescription)]
unique = [(Path Abs File, GenericPackageDescription)]
packages [(Path Abs File, GenericPackageDescription)]
-> [(Path Abs File, GenericPackageDescription)]
-> [(Path Abs File, GenericPackageDescription)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Path Abs File, GenericPackageDescription)]
dupIgnored
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Path Abs File, GenericPackageDescription)]
dupIgnored [(Path Abs File, GenericPackageDescription)]
-> [(Path Abs File, GenericPackageDescription)] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
[[FilePath]]
dups <- ([(Path Abs File, GenericPackageDescription)]
-> RIO env [FilePath])
-> [[(Path Abs File, GenericPackageDescription)]]
-> RIO env [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Path Abs File, GenericPackageDescription) -> RIO env FilePath)
-> [(Path Abs File, GenericPackageDescription)]
-> RIO env [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Path Abs File -> RIO env FilePath
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 -> RIO env FilePath)
-> ((Path Abs File, GenericPackageDescription) -> Path Abs File)
-> (Path Abs File, GenericPackageDescription)
-> RIO env FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File, GenericPackageDescription) -> Path Abs File
forall a b. (a, b) -> a
fst)) ([(Path Abs File, GenericPackageDescription)]
-> [[(Path Abs File, GenericPackageDescription)]]
forall a.
[(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups [(Path Abs File, GenericPackageDescription)]
packages)
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Following packages have duplicate package names:\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
[Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
"\n" (([FilePath] -> Utf8Builder) -> [[FilePath]] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath] -> Utf8Builder
formatGroup [[FilePath]]
dups))
case Maybe FilePath
dupErrMsg of
Maybe FilePath
Nothing -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Packages with duplicate names will be ignored.\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Packages in upper level directories will be preferred.\n"
Just FilePath
msg -> FilePath -> RIO env ()
forall a. HasCallStack => FilePath -> a
error FilePath
msg
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
-> RIO
env
(Map PackageName (Path Abs File, GenericPackageDescription),
[Path Abs File])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(PackageName, (Path Abs File, GenericPackageDescription))]
-> Map PackageName (Path Abs File, GenericPackageDescription)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
([(PackageName, (Path Abs File, GenericPackageDescription))]
-> Map PackageName (Path Abs File, GenericPackageDescription))
-> [(PackageName, (Path Abs File, GenericPackageDescription))]
-> Map PackageName (Path Abs File, GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ((Path Abs File, GenericPackageDescription)
-> (PackageName, (Path Abs File, GenericPackageDescription)))
-> [(Path Abs File, GenericPackageDescription)]
-> [(PackageName, (Path Abs File, GenericPackageDescription))]
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
, ((Path Abs File, GenericPackageDescription) -> Path Abs File)
-> [(Path Abs File, GenericPackageDescription)] -> [Path Abs File]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File, GenericPackageDescription) -> Path Abs File
forall a b. (a, b) -> a
fst [(Path Abs File, GenericPackageDescription)]
dupIgnored)
formatGroup :: [String] -> Utf8Builder
formatGroup :: [FilePath] -> Utf8Builder
formatGroup = (FilePath -> Utf8Builder) -> [FilePath] -> Utf8Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\FilePath
path -> Utf8Builder
"- " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
path Utf8Builder -> Utf8Builder -> Utf8Builder
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 :: Path r t -> m FilePath
prettyPath Path r t
path = do
Either PathException (Path Rel t)
eres <- IO (Either PathException (Path Rel t))
-> m (Either PathException (Path Rel t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PathException (Path Rel t))
-> m (Either PathException (Path Rel t)))
-> IO (Either PathException (Path Rel t))
-> m (Either PathException (Path Rel t))
forall a b. (a -> b) -> a -> b
$ IO (Path Rel t) -> IO (Either PathException (Path Rel t))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO (Path Rel t) -> IO (Either PathException (Path Rel t)))
-> IO (Path Rel t) -> IO (Either PathException (Path Rel t))
forall a b. (a -> b) -> a -> b
$ Path r t -> IO (RelPath (Path r t))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
makeRelativeToCurrentDir Path r t
path
FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ case Either PathException (Path Rel t)
eres of
Left (PathException
_ :: PathException) -> Path r t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path r t
path
Right Path Rel t
res -> Path Rel t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel t
res