{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}

-- | Types and functions related to Stack's @init@ command.

module Stack.Init
  ( InitOpts (..)
  , initCmd
  , initProject
  ) where

import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Foldable as F
import qualified Data.IntMap as IntMap
import           Data.List.Extra ( groupSortOn )
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import qualified Distribution.Text as C
import qualified Distribution.Version as C
import           Path
                   ( PathException, (</>), dirname, filename, parent
                   , stripProperPrefix
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.Find ( findFiles )
import           Path.IO
                   ( AnyPath, RelPath, doesFileExist, getCurrentDir
                   ,  makeRelativeToCurrentDir, resolveDir'
                   )
import qualified RIO.FilePath as FP
import           RIO.List ( (\\), intercalate, isSuffixOf, isPrefixOf )
import           RIO.List.Partial ( minimumBy )
import           Stack.BuildPlan
                   ( BuildPlanCheck (..), checkSnapBuildPlan, deNeededBy
                   , removeSrcPkgDefaultFlags, selectBestSnapshot
                   )
import           Stack.Config ( getSnapshots, makeConcreteResolver )
import           Stack.Constants ( stackDotYaml, stackProgName' )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withGlobalProject )
import           Stack.SourceMap
                   ( SnapshotCandidate, loadProjectSnapshotCandidate )
import           Stack.Types.Config ( HasConfig )
import           Stack.Types.GHCVariant ( HasGHCVariant )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Project ( Project (..) )
import           Stack.Types.Runner (Runner, globalOptsL )
import           Stack.Types.Resolver ( AbstractResolver, Snapshots (..) )
import           Stack.Types.Version ( stackMajorVersion )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Init" module.

data InitException
  = NoPackagesToIgnoreBug
  deriving (Int -> InitException -> ShowS
[InitException] -> ShowS
InitException -> FilePath
(Int -> InitException -> ShowS)
-> (InitException -> FilePath)
-> ([InitException] -> ShowS)
-> Show InitException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitException -> ShowS
showsPrec :: Int -> InitException -> ShowS
$cshow :: InitException -> FilePath
show :: InitException -> FilePath
$cshowList :: [InitException] -> ShowS
showList :: [InitException] -> ShowS
Show, Typeable)

instance Exception InitException where
  displayException :: InitException -> FilePath
displayException InitException
NoPackagesToIgnoreBug = FilePath -> ShowS
bugReport FilePath
"[S-2747]"
    FilePath
"No packages to ignore."

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Init" module.

data InitPrettyException
  = SnapshotDownloadFailure SomeException
  | ConfigFileAlreadyExists FilePath
  | PackageNameInvalid [(Path Abs File, PackageName)]
  | NoMatchingSnapshot !(NonEmpty SnapName)
  | ResolverMismatch !RawSnapshotLocation String
  | ResolverPartial !RawSnapshotLocation !String
  deriving (Int -> InitPrettyException -> ShowS
[InitPrettyException] -> ShowS
InitPrettyException -> FilePath
(Int -> InitPrettyException -> ShowS)
-> (InitPrettyException -> FilePath)
-> ([InitPrettyException] -> ShowS)
-> Show InitPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitPrettyException -> ShowS
showsPrec :: Int -> InitPrettyException -> ShowS
$cshow :: InitPrettyException -> FilePath
show :: InitPrettyException -> FilePath
$cshowList :: [InitPrettyException] -> ShowS
showList :: [InitPrettyException] -> ShowS
Show, Typeable)

instance Pretty InitPrettyException where
  pretty :: InitPrettyException -> StyleDoc
pretty (ConfigFileAlreadyExists FilePath
reldest) =
    StyleDoc
"[S-8009]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Stack declined to create a project-level YAML configuration file."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ FilePath -> StyleDoc
flow FilePath
"The file"
         , Style -> StyleDoc -> StyleDoc
style Style
File (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
reldest)
         , StyleDoc
"already exists. To overwrite it, pass the flag"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--force" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (PackageNameInvalid [(Path Abs File, PackageName)]
rels) =
    StyleDoc
"[S-5267]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Stack did not create project-level YAML configuration, as (like \
            \Hackage) it requires a Cabal file name to match the package it \
            \defines."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Please rename the following Cabal files:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
         ( ((Path Abs File, PackageName) -> StyleDoc)
-> [(Path Abs File, PackageName)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
             ( \(Path Abs File
fp, PackageName
name) -> [StyleDoc] -> StyleDoc
fillSep
                 [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
                 , StyleDoc
"as"
                 , Style -> StyleDoc -> StyleDoc
style
                     Style
File
                     (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
".cabal")
                 ]
             )
             [(Path Abs File, PackageName)]
rels
         )
  pretty (SnapshotDownloadFailure SomeException
e) =
    StyleDoc
"[S-8332]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Stack failed to create project-level YAML configuration, as it \
            \was unable to download the index of available snapshots."
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ FilePath -> StyleDoc
flow FilePath
"This sometimes happens because Certificate Authorities are \
                \missing on your system. You can try the Stack command again \
                \or manually create the configuration file. For help about the \
                \content of Stack's YAML configuration files, see (for the \
                \most recent release of Stack)"
         , Style -> StyleDoc -> StyleDoc
style
             Style
Url
             StyleDoc
"http://docs.haskellstack.org/en/stable/yaml_configuration/"
           StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"While downloading the snapshot index, Stack encountered the \
            \following error:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
string (SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
e)
  pretty (NoMatchingSnapshot NonEmpty SnapName
names) =
    StyleDoc
"[S-1833]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"None of the following snapshots provides a compiler matching \
            \your package(s):"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((SnapName -> StyleDoc) -> [SnapName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc)
-> (SnapName -> FilePath) -> SnapName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapName -> FilePath
forall a. Show a => a -> FilePath
show) (NonEmpty SnapName -> [SnapName]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty SnapName
names))
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
resolveOptions
  pretty (ResolverMismatch RawSnapshotLocation
resolver FilePath
errDesc) =
    StyleDoc
"[S-6395]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Snapshot"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (PrettyRawSnapshotLocation -> StyleDoc)
-> PrettyRawSnapshotLocation -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
resolver)
         , FilePath -> StyleDoc
flow FilePath
"does not have a matching compiler to build some or all of \
                \your package(s)."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (FilePath -> StyleDoc
string FilePath
errDesc)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
resolveOptions
  pretty (ResolverPartial RawSnapshotLocation
resolver FilePath
errDesc) =
    StyleDoc
"[S-2422]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Snapshot"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (PrettyRawSnapshotLocation -> StyleDoc)
-> PrettyRawSnapshotLocation -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
resolver)
         , FilePath -> StyleDoc
flow FilePath
"does not have all the packages to match your requirements."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (FilePath -> StyleDoc
string FilePath
errDesc)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
resolveOptions

resolveOptions :: StyleDoc
resolveOptions :: StyleDoc
resolveOptions =
     FilePath -> StyleDoc
flow FilePath
"This may be resolved by:"
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
       [ [StyleDoc] -> StyleDoc
fillSep
           [ StyleDoc
"Using"
           , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--omit-packages"
           , StyleDoc
"to exclude mismatching package(s)."
           ]
       , [StyleDoc] -> StyleDoc
fillSep
           [ StyleDoc
"Using"
           , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--resolver"
           , StyleDoc
"to specify a matching snapshot/resolver."
           ]
       ]

instance Exception InitPrettyException

-- | Type representing command line options for the @stack init@ command.

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

  }

-- | Function underlying the @stack init@ command. Project initialization.

initCmd :: InitOpts -> RIO Runner ()
initCmd :: InitOpts -> RIO Runner ()
initCmd InitOpts
initOpts = do
  Path Abs Dir
pwd <- RIO Runner (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  GlobalOpts
go <- Getting GlobalOpts Runner GlobalOpts -> RIO Runner GlobalOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GlobalOpts Runner GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL
  RIO Runner () -> RIO Runner ()
forall a. RIO Runner a -> RIO Runner a
withGlobalProject (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
    ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO Config ()
forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO env ()
initProject Path Abs Dir
pwd InitOpts
initOpts (GlobalOpts -> Maybe AbstractResolver
globalResolver GlobalOpts
go))

-- | Generate a @stack.yaml@ file.

initProject ::
     (HasConfig env, HasGHCVariant env)
  => Path Abs Dir
  -> InitOpts
  -> Maybe AbstractResolver
  -> RIO env ()
initProject :: forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO env ()
initProject Path Abs Dir
currDir InitOpts
initOpts Maybe AbstractResolver
mresolver = do
  let dest :: Path Abs File
dest = Path Abs Dir
currDir 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs File -> RIO env (RelPath (Path Abs File))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (RelPath (Path Abs File))
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
$
    InitPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (InitPrettyException -> RIO env ())
-> InitPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> InitPrettyException
ConfigFileAlreadyExists FilePath
reldest
  [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs then [Path Abs Dir
currDir] else [Path Abs Dir]
dirs
  StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
       [StyleDoc] -> StyleDoc
fillSep
         [ FilePath -> StyleDoc
flow FilePath
"Looking for Cabal or"
         , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"package.yaml"
         , FilePath -> StyleDoc
flow FilePath
"files to use to initialise Stack's project-level YAML \
                \configuration file."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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]
-> RIO
     env
     (Map PackageName (Path Abs File, GenericPackageDescription),
      [Path Abs File])
forall env.
(HasConfig env, HasGHCVariant env) =>
[Path Abs Dir]
-> RIO
     env
     (Map PackageName (Path Abs File, GenericPackageDescription),
      [Path Abs File])
cabalPackagesCheck [Path Abs Dir]
cabaldirs
  let makeRelDir :: Path Abs Dir -> FilePath
makeRelDir Path Abs Dir
dir =
        case 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 -> ShowS
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False ShowS -> ShowS
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 -> ShowS
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
        { 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 a b. (a -> b) -> RIO env a -> RIO env b
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)
Path Abs File -> RIO env (RelPath (Path Abs File))
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (RelPath path)
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m (RelPath (Path Abs File))
makeRelativeToCurrentDir
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Initialising Stack's project-level YAML configuration file \
           \using snapshot"
    , PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
snapshotLoc) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL ([StyleDoc] -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    let n :: Int
n = 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs
    in  [ StyleDoc
"Considered"
        , FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n
        , StyleDoc
"user"
        , if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then StyleDoc
"package." else StyleDoc
"packages."
        ]
  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
    [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Path Abs File -> RIO env FilePath
makeRel [Path Abs File]
dupPkgs
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ FilePath -> StyleDoc
flow FilePath
"Ignoring these"
           , FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show ([Path Abs File] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
dupPkgs)
           , FilePath -> StyleDoc
flow FilePath
"duplicate packages:"
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((FilePath -> StyleDoc) -> [FilePath] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString) [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
    [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a b. (a -> b) -> Map PackageName a -> Map PackageName b
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))
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ FilePath -> StyleDoc
flow FilePath
"Ignoring these"
           , FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show (Map PackageName (Path Abs File, GenericPackageDescription) -> Int
forall k a. Map k a -> Int
Map.size Map PackageName (Path Abs File, GenericPackageDescription)
ignored)
           , FilePath -> StyleDoc
flow FilePath
"packages due to dependency conflicts:"
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((FilePath -> StyleDoc) -> [FilePath] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString) [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
$
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show (Map PackageName Version -> Int
forall k a. Map k a -> Int
Map.size Map PackageName Version
extraDeps)
      , FilePath -> StyleDoc
flow FilePath
"external dependencies were added."
      ]
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ if Bool
exists
        then FilePath
"Overwriting existing configuration file"
        else FilePath
"Writing configuration to"
    , Style -> StyleDoc -> StyleDoc
style Style
File (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
reldest) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  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 a b. (a -> b) -> Map PackageName a -> Map PackageName b
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)
  FilePath -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
prettyInfoS
    FilePath
"Stack's project-level YAML configuration file has been initialised."

-- | 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. (?callStack::CallStack) => 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
<> ((Key, ByteString) -> Builder) -> [(Key, ByteString)] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (Object -> (Key, ByteString) -> Builder
goComment Object
o) [(Key, ByteString)]
comments
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Object -> Builder
forall {v}. ToJSON v => KeyMap v -> Builder
goOthers (Object
o Object -> KeyMap ByteString -> Object
forall v v'. KeyMap v -> KeyMap v' -> KeyMap v
`KeyMap.difference` [(Key, ByteString)] -> KeyMap ByteString
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key, 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 -> (Key, ByteString) -> Builder
goComment Object
o (Key
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
<$> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
name Object
o) Maybe Builder -> Maybe Builder -> Maybe Builder
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Key -> Maybe Builder
forall {a} {a}. (Eq a, IsString a, IsString a) => a -> Maybe a
nonPresentValue Key
name of
      Maybe Builder
Nothing -> Bool -> Builder -> Builder
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Key
name Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
"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 Key
name Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
"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 [(Key
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 :: ShowS
commentLine FilePath
l | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
l = FilePath
"#"
                | Bool
otherwise = FilePath
"# " FilePath -> ShowS
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
. ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
commentLine
  commentedPackages :: Builder
commentedPackages =
    let ignoredComment :: ByteString
ignoredComment = [FilePath] -> ByteString
commentHelp
          [ FilePath
"The following packages have been ignored due to incompatibility with the"
          , FilePath
"resolver compiler, dependency conflicts with other packages"
          , FilePath
"or unsatisfied dependencies."
          ]
        dupComment :: ByteString
dupComment = [FilePath] -> ByteString
commentHelp
          [ FilePath
"The following packages have been ignored due to package name conflict "
          , FilePath
"with other packages."
          ]
    in  ByteString -> [FilePath] -> Builder
commentPackages ByteString
ignoredComment [FilePath]
ignoredPackages
        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
$ ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> FilePath
"#- " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
x FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n") [FilePath]
pkgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"\n"])
    | Bool
otherwise = Builder
""
  goOthers :: KeyMap v -> Builder
goOthers KeyMap v
o
    | KeyMap v -> Bool
forall v. KeyMap v -> Bool
KeyMap.null KeyMap v
o = Builder
forall a. Monoid a => a
mempty
    | Bool
otherwise = Bool -> Builder -> Builder
forall a. (?callStack::CallStack) => 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
$ KeyMap v -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode KeyMap v
o
  -- Per Section Help

  comments :: [(Key, ByteString)]
comments =
    [ (Key
"user-message"     , ByteString
userMsgHelp)
    , (Key
"resolver"         , ByteString
resolverHelp)
    , (Key
"packages"         , ByteString
packageHelp)
    , (Key
"extra-deps"       , ByteString
extraDepsHelp)
    , (Key
"flags"            , ByteString
"# Override default flag values for local packages and extra-deps")
    , (Key
"extra-package-dbs", ByteString
"# Extra package databases containing global packages")
    ]
  -- 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-21.13"
    , FilePath
"resolver: nightly-2023-09-24"
    , FilePath
"resolver: ghc-9.6.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/2023-01-01.yaml"
    ]
  userMsgHelp :: ByteString
userMsgHelp = [FilePath] -> ByteString
commentHelp
    [ FilePath
"A warning or info to be displayed to the user on config load." ]
  packageHelp :: ByteString
packageHelp = [FilePath] -> ByteString
commentHelp
    [ FilePath
"User packages to be built."
    , FilePath
"Various formats can be used as shown in the example below."
    , FilePath
""
    , FilePath
"packages:"
    , FilePath
"- some-directory"
    , FilePath
"- https://example.com/foo/bar/baz-0.0.2.tar.gz"
    , FilePath
"  subdirs:"
    , FilePath
"  - auto-update"
    , FilePath
"  - wai"
    ]
  extraDepsHelp :: ByteString
extraDepsHelp = [FilePath] -> ByteString
commentHelp
    [ FilePath
"Dependency packages to be pulled from upstream that are not in the resolver."
    , FilePath
"These entries can reference officially published versions as well as"
    , FilePath
"forks / in-progress versions pinned to a git hash. For example:"
    , FilePath
""
    , FilePath
"extra-deps:"
    , FilePath
"- acme-missiles-0.3"
    , FilePath
"- git: https://github.com/commercialhaskell/stack.git"
    , FilePath
"  commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a"
    , FilePath
""
    ]
  footerHelp :: ByteString
footerHelp = [FilePath] -> ByteString
commentHelp
    [ FilePath
"Control whether we use the GHC we find on the path"
    , FilePath
"system-ghc: true"
    , FilePath
""
    , FilePath
"Require a specific version of Stack, using version ranges"
    , FilePath
"require-stack-version: -any # Default"
    , FilePath
"require-stack-version: \""
      FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionRange -> FilePath
forall a. Pretty a => a -> FilePath
C.display (Version -> VersionRange
C.orLaterVersion Version
stackMajorVersion) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\""
    , FilePath
""
    , FilePath
"Override the architecture used by Stack, especially useful on Windows"
    , FilePath
"arch: i386"
    , FilePath
"arch: x86_64"
    , FilePath
""
    , FilePath
"Extra directories used by Stack for building"
    , FilePath
"extra-include-dirs: [/path/to/dir]"
    , FilePath
"extra-lib-dirs: [/path/to/dir]"
    , FilePath
""
    , FilePath
"Allow a newer minor version of GHC than the snapshot specifies"
    , FilePath
"compiler-check: newer-minor"
    ]

getSnapshots' :: HasConfig env => RIO env Snapshots
getSnapshots' :: forall env. HasConfig env => RIO env Snapshots
getSnapshots' = RIO env Snapshots
-> (SomeException -> RIO env Snapshots) -> RIO env Snapshots
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
  RIO env Snapshots
forall env. HasConfig env => RIO env Snapshots
getSnapshots
  (InitPrettyException -> RIO env Snapshots
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (InitPrettyException -> RIO env Snapshots)
-> (SomeException -> InitPrettyException)
-> SomeException
-> RIO env Snapshots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> InitPrettyException
SnapshotDownloadFailure)

-- | 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 :: forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> Maybe AbstractResolver
-> Map PackageName (ResolvedPath Dir)
-> RIO
     env
     (RawSnapshotLocation, Map PackageName (Map FlagName Bool),
      Map PackageName Version, Map PackageName (ResolvedPath Dir))
getDefaultResolver InitOpts
initOpts Maybe AbstractResolver
mresolver Map PackageName (ResolvedPath Dir)
pkgDirs = do
  (SnapshotCandidate env
candidate, RawSnapshotLocation
loc) <- case Maybe AbstractResolver
mresolver of
    Maybe AbstractResolver
Nothing -> RIO env (SnapshotCandidate env, RawSnapshotLocation)
selectSnapResolver
    Just AbstractResolver
ar -> do
      RawSnapshotLocation
sl <- 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a b. (a -> b) -> RIO env a -> RIO env b
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)
              -> InitPrettyException
-> RIO env (SnapshotCandidate env, RawSnapshotLocation)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (InitPrettyException
 -> RIO env (SnapshotCandidate env, RawSnapshotLocation))
-> InitPrettyException
-> RIO env (SnapshotCandidate env, RawSnapshotLocation)
forall a b. (a -> b) -> a -> b
$ NonEmpty SnapName -> InitPrettyException
NoMatchingSnapshot NonEmpty SnapName
snaps
      BuildPlanCheck
_ -> (SnapshotCandidate env, RawSnapshotLocation)
-> RIO env (SnapshotCandidate env, RawSnapshotLocation)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> Map PackageName (ResolvedPath Dir)
-> SnapshotCandidate env
-> RawSnapshotLocation
-> RIO
     env
     (RawSnapshotLocation, Map PackageName (Map FlagName Bool),
      Map PackageName Version, Map PackageName (ResolvedPath Dir))
getWorkingResolverPlan InitOpts
initOpts Map PackageName (ResolvedPath Dir)
pkgDirs0 SnapshotCandidate env
snapCandidate RawSnapshotLocation
snapLoc = do
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Selected the snapshot"
    , PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
snapLoc) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  Map PackageName (ResolvedPath Dir)
-> RIO
     env
     (RawSnapshotLocation, Map PackageName (Map FlagName Bool),
      Map PackageName Version, Map PackageName (ResolvedPath Dir))
go Map PackageName (ResolvedPath Dir)
pkgDirs0
 where
  go :: Map PackageName (ResolvedPath Dir)
-> RIO
     env
     (RawSnapshotLocation, Map PackageName (Map FlagName Bool),
      Map PackageName Version, Map PackageName (ResolvedPath Dir))
go Map PackageName (ResolvedPath Dir)
pkgDirs = do
    Either
  [PackageName]
  (Map PackageName (Map FlagName Bool), Map PackageName Version)
eres <- 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation
snapLoc, Map PackageName (Map FlagName Bool)
f, Map PackageName Version
edeps, Map PackageName (ResolvedPath Dir)
pkgDirs)
      Left [PackageName]
ignored
        | Map PackageName (ResolvedPath Dir) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (ResolvedPath Dir)
available -> do
            FilePath -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
prettyWarnS
              FilePath
"Could not find a working plan for any of the user packages. \
              \Proceeding to create a YAML configuration file 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
$
              InitException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InitException
NoPackagesToIgnoreBug
            if [PackageName] -> Int
forall a. [a] -> 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
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn
                  (  FilePath -> StyleDoc
flow FilePath
"Ignoring the following packages:"
                  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
                  StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
                       ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc)
-> (PackageName -> FilePath) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString) [PackageName]
ignored)
                  )
              else
                [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                  [ FilePath -> StyleDoc
flow FilePath
"Ignoring package:"
                  , FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString
                      ( case [PackageName]
ignored of
                          [] -> InitException -> FilePath
forall e a. Exception e => e -> [a]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InitException
NoPackagesToIgnoreBug
                          PackageName
x:[PackageName]
_ -> PackageName -> FilePath
packageNameString PackageName
x
                      )
                  ]
            Map PackageName (ResolvedPath Dir)
-> RIO
     env
     (RawSnapshotLocation, Map PackageName (Map FlagName Bool),
      Map PackageName Version, Map PackageName (ResolvedPath Dir))
go Map PackageName (ResolvedPath Dir)
available
       where
        isAvailable :: PackageName -> ResolvedPath Dir -> Bool
isAvailable PackageName
k ResolvedPath Dir
_ = PackageName
k 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 :: forall env.
(HasConfig env, HasGHCVariant env) =>
InitOpts
-> RawSnapshotLocation
-> SnapshotCandidate env
-> [ResolvedPath Dir]
-> RIO
     env
     (Either
        [PackageName]
        (Map PackageName (Map FlagName Bool), Map PackageName Version))
checkBundleResolver InitOpts
initOpts RawSnapshotLocation
snapshotLoc SnapshotCandidate env
snapCandidate [ResolvedPath Dir]
pkgDirs = do
  BuildPlanCheck
result <- [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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
          FilePath -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
FilePath -> m ()
prettyWarnS FilePath
"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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
          InitPrettyException
-> RIO
     env
     (Either
        [PackageName]
        (Map PackageName (Map FlagName Bool), Map PackageName Version))
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (InitPrettyException
 -> RIO
      env
      (Either
         [PackageName]
         (Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> InitPrettyException
-> RIO
     env
     (Either
        [PackageName]
        (Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> InitPrettyException
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
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [StyleDoc] -> StyleDoc
fillSep
                 [ StyleDoc
"Resolver compiler mismatch:"
                 , Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> (Text -> FilePath) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
snapshotLoc)
                 ]
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (FilePath -> StyleDoc
string (FilePath -> StyleDoc) -> FilePath -> StyleDoc
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> InitPrettyException
-> RIO
     env
     (Either
        [PackageName]
        (Map PackageName (Map FlagName Bool), Map PackageName Version))
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (InitPrettyException
 -> RIO
      env
      (Either
         [PackageName]
         (Map PackageName (Map FlagName Bool), Map PackageName Version)))
-> InitPrettyException
-> RIO
     env
     (Either
        [PackageName]
        (Map PackageName (Map FlagName Bool), Map PackageName Version))
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> InitPrettyException
ResolverMismatch RawSnapshotLocation
snapshotLoc (BuildPlanCheck -> FilePath
forall a. Show a => a -> FilePath
show BuildPlanCheck
result)
 where
  warnPartial :: BuildPlanCheck -> RIO env ()
warnPartial BuildPlanCheck
res = do
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ StyleDoc
"Resolver"
           , Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> (Text -> FilePath) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Text
forall a. Display a => a -> Text
textDisplay RawSnapshotLocation
snapshotLoc)
           , FilePath -> StyleDoc
flow FilePath
"will need external packages:"
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (FilePath -> StyleDoc
string (FilePath -> StyleDoc) -> FilePath -> StyleDoc
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 a b. (a -> b) -> Map k a -> Map k b
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]
supportedLtss 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)
  supportedLtss :: [SnapName]
supportedLtss = (SnapName -> Bool) -> [SnapName] -> [SnapName]
forall a. (a -> Bool) -> [a] -> [a]
filter (SnapName -> SnapName -> Bool
forall a. Ord a => a -> a -> Bool
>= SnapName
minSupportedLts) [SnapName]
ltss
  nightly :: SnapName
nightly = Day -> SnapName
Nightly (Snapshots -> Day
snapshotsNightly Snapshots
snapshots)

-- |Yields the minimum LTS supported by Stack.

minSupportedLts :: SnapName
-- See https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md

-- under Stack version 2.1.1.

minSupportedLts :: SnapName
minSupportedLts = Int -> Int -> SnapName
LTS Int
3 Int
0

findCabalDirs ::
     HasConfig env
  => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs :: forall env.
HasConfig env =>
Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir))
findCabalDirs Bool
recurse Path Abs Dir
dir =
  [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 a. IO a -> RIO env a
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" `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 = ShowS
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]
  -> RIO env
       ( Map PackageName (Path Abs File, C.GenericPackageDescription)
       , [Path Abs File]
       )
cabalPackagesCheck :: forall env.
(HasConfig env, HasGHCVariant env) =>
[Path Abs Dir]
-> RIO
     env
     (Map PackageName (Path Abs File, GenericPackageDescription),
      [Path Abs File])
cabalPackagesCheck [Path Abs Dir]
cabaldirs = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs Dir] -> Bool
forall a. [a] -> 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
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ FilePath -> StyleDoc
flow FilePath
"Stack did not find any local package directories. You may \
                  \want to create a package with"
           , Style -> StyleDoc -> StyleDoc
style Style
Shell (FilePath -> StyleDoc
flow FilePath
"stack new")
           , FilePath -> StyleDoc
flow FilePath
"instead."
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
           [ FilePath -> StyleDoc
flow FilePath
"Stack will create an empty project. If this is not what \
                  \you want, please delete the generated"
           , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"stack.yaml"
           , StyleDoc
"file."
           ]
  [FilePath]
relpaths <- (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
relpaths) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         FilePath -> StyleDoc
flow FilePath
"Using the Cabal packages:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((FilePath -> StyleDoc) -> [FilePath] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString) [FilePath]
relpaths)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  -- A 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.

  [Either
   (Path Abs File, PackageName)
   (Path Abs File, GenericPackageDescription)]
ePackages <- [Path Abs Dir]
-> (Path Abs Dir
    -> RIO
         env
         (Either
            (Path Abs File, PackageName)
            (Path Abs File, GenericPackageDescription)))
-> RIO
     env
     [Either
        (Path Abs File, PackageName)
        (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
       (Either
          (Path Abs File, PackageName)
          (Path Abs File, GenericPackageDescription)))
 -> RIO
      env
      [Either
         (Path Abs File, PackageName)
         (Path Abs File, GenericPackageDescription)])
-> (Path Abs Dir
    -> RIO
         env
         (Either
            (Path Abs File, PackageName)
            (Path Abs File, GenericPackageDescription)))
-> RIO
     env
     [Either
        (Path Abs File, PackageName)
        (Path Abs File, GenericPackageDescription)]
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
    -- Pantry's 'loadCabalFilePath' throws 'MismatchedCabalName' (error

    -- [S-910]) if the Cabal file name does not match the package it

    -- defines.

    (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
cabalfp) <- Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
dir
    Either PantryException GenericPackageDescription
eres <- IO (Either PantryException GenericPackageDescription)
-> RIO env (Either PantryException GenericPackageDescription)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PantryException GenericPackageDescription)
 -> RIO env (Either PantryException GenericPackageDescription))
-> IO (Either PantryException GenericPackageDescription)
-> RIO env (Either PantryException GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ IO GenericPackageDescription
-> IO (Either PantryException GenericPackageDescription)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings)
    case Either PantryException GenericPackageDescription
eres :: Either PantryException C.GenericPackageDescription of
      Right GenericPackageDescription
gpd -> Either
  (Path Abs File, PackageName)
  (Path Abs File, GenericPackageDescription)
-> RIO
     env
     (Either
        (Path Abs File, PackageName)
        (Path Abs File, GenericPackageDescription))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (Path Abs File, PackageName)
   (Path Abs File, GenericPackageDescription)
 -> RIO
      env
      (Either
         (Path Abs File, PackageName)
         (Path Abs File, GenericPackageDescription)))
-> Either
     (Path Abs File, PackageName)
     (Path Abs File, GenericPackageDescription)
-> RIO
     env
     (Either
        (Path Abs File, PackageName)
        (Path Abs File, GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (Path Abs File, GenericPackageDescription)
-> Either
     (Path Abs File, PackageName)
     (Path Abs File, GenericPackageDescription)
forall a b. b -> Either a b
Right (Path Abs File
cabalfp, GenericPackageDescription
gpd)
      Left (MismatchedCabalName Path Abs File
fp PackageName
name) -> Either
  (Path Abs File, PackageName)
  (Path Abs File, GenericPackageDescription)
-> RIO
     env
     (Either
        (Path Abs File, PackageName)
        (Path Abs File, GenericPackageDescription))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (Path Abs File, PackageName)
   (Path Abs File, GenericPackageDescription)
 -> RIO
      env
      (Either
         (Path Abs File, PackageName)
         (Path Abs File, GenericPackageDescription)))
-> Either
     (Path Abs File, PackageName)
     (Path Abs File, GenericPackageDescription)
-> RIO
     env
     (Either
        (Path Abs File, PackageName)
        (Path Abs File, GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (Path Abs File, PackageName)
-> Either
     (Path Abs File, PackageName)
     (Path Abs File, GenericPackageDescription)
forall a b. a -> Either a b
Left (Path Abs File
fp, PackageName
name)
      Left PantryException
e -> PantryException
-> RIO
     env
     (Either
        (Path Abs File, PackageName)
        (Path Abs File, GenericPackageDescription))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
e
  let ([(Path Abs File, PackageName)]
nameMismatchPkgs, [(Path Abs File, GenericPackageDescription)]
packages) = [Either
   (Path Abs File, PackageName)
   (Path Abs File, GenericPackageDescription)]
-> ([(Path Abs File, PackageName)],
    [(Path Abs File, GenericPackageDescription)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (Path Abs File, PackageName)
   (Path Abs File, GenericPackageDescription)]
ePackages
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Path Abs File, PackageName)]
nameMismatchPkgs [(Path Abs File, PackageName)]
-> [(Path Abs File, PackageName)] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    InitPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (InitPrettyException -> RIO env ())
-> InitPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [(Path Abs File, PackageName)] -> InitPrettyException
PackageNameInvalid [(Path Abs File, PackageName)]
nameMismatchPkgs
  let dupGroups :: [(a, GenericPackageDescription)]
-> [[(a, GenericPackageDescription)]]
dupGroups = ([(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 a. [a] -> 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 a. [a] -> 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         FilePath -> StyleDoc
flow FilePath
"The following packages have duplicate package names:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> ([FilePath] -> StyleDoc) -> [[FilePath]] -> StyleDoc
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
           ( \[FilePath]
dup ->    [StyleDoc] -> StyleDoc
bulletedList ((FilePath -> StyleDoc) -> [FilePath] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString [FilePath]
dup)
                     StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
           )
           [[FilePath]]
dups
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Packages with duplicate names will be ignored. Packages \
              \in upper level directories will be preferred."
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  (Map PackageName (Path Abs File, GenericPackageDescription),
 [Path Abs File])
-> RIO
     env
     (Map PackageName (Path Abs File, GenericPackageDescription),
      [Path Abs File])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(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)

prettyPath ::
     (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))
  => Path r t
  -> m FilePath
prettyPath :: forall (m :: * -> *) r t.
(MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) =>
Path r t -> m FilePath
prettyPath Path r t
path = do
  Either PathException (Path Rel t)
eres <- IO (Either PathException (Path Rel t))
-> m (Either PathException (Path Rel t))
forall a. IO a -> m a
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)
forall (m :: * -> *).
MonadIO m =>
Path r t -> m (RelPath (Path r t))
makeRelativeToCurrentDir Path r t
path
  FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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