{-# 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

-- | Generate stack.yaml
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."

-- | Render a stack.yaml file with comments, see:
-- https://github.com/commercialhaskell/stack/issues/226
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)])

        -- Some fields in stack.yaml are optional and may not be
        -- generated. For these, we provided commented out dummy
        -- values to go along with the comments.
        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

    -- Per Section Help
    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")
        ]

    -- Help strings
    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
""

-- | Get the default resolver value
getDefaultResolver
    :: (HasConfig env, HasGHCVariant env)
    => InitOpts
    -> Maybe AbstractResolver
    -> Map PackageName (ResolvedPath Dir)
    -- ^ Src package name: cabal dir
    -> RIO env
         ( RawSnapshotLocation
         , Map PackageName (Map FlagName Bool)
         , Map PackageName Version
         , Map PackageName (ResolvedPath Dir))
       -- ^ ( Resolver
       --   , Flags for src packages and extra deps
       --   , Extra dependencies
       --   , Src packages actually considered)
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
        -- TODO support selecting best across regular and custom snapshots
        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)
    -- ^ Src packages: cabal dir
    -> SnapshotCandidate env
    -> RawSnapshotLocation
    -> RIO env
         ( RawSnapshotLocation
         , Map PackageName (Map FlagName Bool)
         , Map PackageName Version
         , Map PackageName (ResolvedPath Dir))
       -- ^ ( SnapshotDef
       --   , Flags for src packages and extra deps
       --   , Extra dependencies
       --   , Src packages actually considered)
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)
            -- if some packages failed try again using the rest
            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]
    -- ^ Src package dirs
    -> 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 -- FIXME:qrilka unused f
            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 =
    -- in order - Latest LTS, Latest Nightly, all LTS most recent first
    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]
    -- ^ List of sub directories to search for .cabal files
    , InitOpts -> Bool
omitPackages   :: Bool
    -- ^ Exclude conflicting or incompatible user packages
    , InitOpts -> Bool
forceOverwrite :: Bool
    -- ^ Overwrite existing stack.yaml
    , InitOpts -> Bool
includeSubDirs :: Bool
    -- ^ If True, include all .cabal files found in any sub directories
    }

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))

-- | Special directories that we don't want to traverse for .cabal files
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)

    -- package name cannot be empty or missing otherwise
    -- it will result in cabal solver failure.
    -- stack requires packages name to match the cabal file name
    -- Just the latter check is enough to cover both the cases

    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

        -- Among duplicates prefer to include the ones in upper level dirs
        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