{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE NoFieldSelectors    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | Functions related to Stack's @unpack@ command.

module Stack.Unpack
  ( UnpackOpts (..)
  , UnpackTarget
  , unpackCmd
  , unpackPackages
  ) where

import           Data.List.Extra ( notNull )
import           Path ( SomeBase (..), (</>), parseRelDir )
import           Path.IO ( doesDirExist, getCurrentDir )
import           Pantry ( loadSnapshot )
import qualified RIO.Map as Map
import           RIO.Process ( HasProcessContext )
import qualified RIO.Set as Set
import qualified RIO.Text as T
import           Stack.Config ( makeConcreteResolver )
import           Stack.Constants ( relDirRoot )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig )
import           Stack.Types.Config ( Config (..), HasConfig, configL )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )

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

-- "Stack.Unpack" module.

data UnpackPrettyException
  = UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
  | CouldNotParsePackageSelectors [StyleDoc]
  | PackageCandidatesRequireVersions [PackageName]
  | PackageLocationInvalid PackageIdentifierRevision
  deriving (Int -> UnpackPrettyException -> ShowS
[UnpackPrettyException] -> ShowS
UnpackPrettyException -> String
(Int -> UnpackPrettyException -> ShowS)
-> (UnpackPrettyException -> String)
-> ([UnpackPrettyException] -> ShowS)
-> Show UnpackPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnpackPrettyException -> ShowS
showsPrec :: Int -> UnpackPrettyException -> ShowS
$cshow :: UnpackPrettyException -> String
show :: UnpackPrettyException -> String
$cshowList :: [UnpackPrettyException] -> ShowS
showList :: [UnpackPrettyException] -> ShowS
Show, Typeable)

instance Pretty UnpackPrettyException where
  pretty :: UnpackPrettyException -> StyleDoc
pretty (UnpackDirectoryAlreadyExists Set (Path Abs Dir)
dirs) =
    StyleDoc
"[S-3515]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack was unable to unpack due to directories already being \
            \present:"
    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 Dir -> StyleDoc) -> [Path Abs Dir] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty ([Path Abs Dir] -> [StyleDoc]) -> [Path Abs Dir] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ Set (Path Abs Dir) -> [Path Abs Dir]
forall a. Set a -> [a]
Set.toList Set (Path Abs Dir)
dirs)
  pretty (CouldNotParsePackageSelectors [StyleDoc]
errs) =
    StyleDoc
"[S-2628]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"The following package selectors are not valid package names or \
            \identifiers:"
    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]
errs
  pretty (PackageCandidatesRequireVersions [PackageName]
names) =
    StyleDoc
"[S-6114]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Package candidates to unpack cannot be identified by name only. \
            \The following do not specify a version:"
    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 PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName [PackageName]
names)
  pretty (PackageLocationInvalid PackageIdentifierRevision
pir) =
    StyleDoc
"[S-5170]"
    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
         [ String -> StyleDoc
flow String
"While trying to unpack"
         , Style -> StyleDoc -> StyleDoc
style Style
Target (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PackageIdentifierRevision -> Text
forall a. Display a => a -> Text
textDisplay PackageIdentifierRevision
pir) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , String -> StyleDoc
flow String
"Stack encountered an error."
         ]

instance Exception UnpackPrettyException

-- | Type synonymn representing packages to be unpacked by the @stack unpack@

-- command, identified either by name only or by an identifier (including

-- Hackage revision).

type UnpackTarget = Either PackageName PackageIdentifierRevision

-- | Type representing options for the @stack unpack@ command.

data UnpackOpts = UnpackOpts
  { UnpackOpts -> [UnpackTarget]
targets :: [UnpackTarget]
    -- ^ The packages or package candidates to be unpacked.

  , UnpackOpts -> Bool
areCandidates :: Bool
    -- ^ Whether the targets are Hackage package candidates.

  , UnpackOpts -> Maybe (SomeBase Dir)
dest :: Maybe (SomeBase Dir)
    -- ^ The optional directory into which a target will be unpacked into a

    -- subdirectory.

  }

-- | Function underlying the @stack unpack@ command. Unpack packages or package

-- candidates to the filesystem.

unpackCmd ::
     UnpackOpts
  -> RIO Runner ()
unpackCmd :: UnpackOpts -> RIO Runner ()
unpackCmd (UnpackOpts [UnpackTarget]
targets Bool
areCandidates Maybe (SomeBase Dir)
Nothing) =
  UnpackOpts -> RIO Runner ()
unpackCmd ([UnpackTarget] -> Bool -> Maybe (SomeBase Dir) -> UnpackOpts
UnpackOpts [UnpackTarget]
targets Bool
areCandidates (SomeBase Dir -> Maybe (SomeBase Dir)
forall a. a -> Maybe a
Just (SomeBase Dir -> Maybe (SomeBase Dir))
-> SomeBase Dir -> Maybe (SomeBase Dir)
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> SomeBase Dir
forall t. Path Rel t -> SomeBase t
Rel Path Rel Dir
relDirRoot))
unpackCmd (UnpackOpts [UnpackTarget]
targets Bool
areCandidates (Just SomeBase Dir
dstPath)) =
  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe AbstractResolver
mresolver <- Getting (Maybe AbstractResolver) Config (Maybe AbstractResolver)
-> RIO Config (Maybe AbstractResolver)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe AbstractResolver) Config (Maybe AbstractResolver)
 -> RIO Config (Maybe AbstractResolver))
-> Getting (Maybe AbstractResolver) Config (Maybe AbstractResolver)
-> RIO Config (Maybe AbstractResolver)
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> Config -> Const (Maybe AbstractResolver) Config
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Config GlobalOpts
globalOptsL ((GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
 -> Config -> Const (Maybe AbstractResolver) Config)
-> ((Maybe AbstractResolver
     -> Const (Maybe AbstractResolver) (Maybe AbstractResolver))
    -> GlobalOpts -> Const (Maybe AbstractResolver) GlobalOpts)
-> Getting (Maybe AbstractResolver) Config (Maybe AbstractResolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> Maybe AbstractResolver)
-> SimpleGetter GlobalOpts (Maybe AbstractResolver)
forall s a. (s -> a) -> SimpleGetter s a
to (.resolver)
    Maybe RawSnapshot
mSnapshot <- Maybe AbstractResolver
-> (AbstractResolver -> RIO Config RawSnapshot)
-> RIO Config (Maybe RawSnapshot)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe AbstractResolver
mresolver ((AbstractResolver -> RIO Config RawSnapshot)
 -> RIO Config (Maybe RawSnapshot))
-> (AbstractResolver -> RIO Config RawSnapshot)
-> RIO Config (Maybe RawSnapshot)
forall a b. (a -> b) -> a -> b
$ \AbstractResolver
resolver -> do
      RawSnapshotLocation
concrete <- AbstractResolver -> RIO Config RawSnapshotLocation
forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
resolver
      SnapshotLocation
loc <- RawSnapshotLocation -> RIO Config SnapshotLocation
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation RawSnapshotLocation
concrete
      SnapshotLocation -> RIO Config RawSnapshot
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot SnapshotLocation
loc
    Path Abs Dir
dstPath' <- case SomeBase Dir
dstPath of
      Abs Path Abs Dir
path -> Path Abs Dir -> RIO Config (Path Abs Dir)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
path
      Rel Path Rel Dir
path -> do
        Path Abs Dir
wd <- RIO Config (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
        Path Abs Dir -> RIO Config (Path Abs Dir)
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir -> RIO Config (Path Abs Dir))
-> Path Abs Dir -> RIO Config (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
wd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
path
    Maybe RawSnapshot
-> Path Abs Dir -> [UnpackTarget] -> Bool -> RIO Config ()
forall env.
(HasConfig env, HasPantryConfig env, HasProcessContext env,
 HasTerm env) =>
Maybe RawSnapshot
-> Path Abs Dir -> [UnpackTarget] -> Bool -> RIO env ()
unpackPackages Maybe RawSnapshot
mSnapshot Path Abs Dir
dstPath' [UnpackTarget]
targets Bool
areCandidates

-- | Intended to work for the command line command.

unpackPackages ::
     forall env.
       (HasConfig env, HasPantryConfig env, HasProcessContext env, HasTerm env)
  => Maybe RawSnapshot -- ^ When looking up by name, take from this build plan.

  -> Path Abs Dir -- ^ Destination.

  -> [UnpackTarget]
  -> Bool
     -- ^ Whether the targets are package candidates.

  -> RIO env ()
unpackPackages :: forall env.
(HasConfig env, HasPantryConfig env, HasProcessContext env,
 HasTerm env) =>
Maybe RawSnapshot
-> Path Abs Dir -> [UnpackTarget] -> Bool -> RIO env ()
unpackPackages Maybe RawSnapshot
mSnapshot Path Abs Dir
dest [UnpackTarget]
targets Bool
areCandidates = do
  let ([PackageName]
names, [PackageIdentifierRevision]
pirs) = [UnpackTarget] -> ([PackageName], [PackageIdentifierRevision])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [UnpackTarget]
targets
      pisWithRevisions :: Bool
pisWithRevisions = (PackageIdentifierRevision -> Bool)
-> [PackageIdentifierRevision] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PackageIdentifierRevision -> Bool
hasRevision [PackageIdentifierRevision]
pirs
      hasRevision :: PackageIdentifierRevision -> Bool
hasRevision (PackageIdentifierRevision PackageName
_ Version
_ CabalFileInfo
CFILatest) = Bool
False
      hasRevision PackageIdentifierRevision
_ = Bool
True
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
areCandidates Bool -> Bool -> Bool
&& [PackageName] -> Bool
forall a. [a] -> Bool
notNull [PackageName]
names) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    UnpackPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (UnpackPrettyException -> RIO env ())
-> UnpackPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [PackageName] -> UnpackPrettyException
PackageCandidatesRequireVersions [PackageName]
names
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
areCandidates Bool -> Bool -> Bool
&& Bool
pisWithRevisions) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         String -> StyleDoc
flow String
"Package revisions are not meaningful for package candidates and \
              \will be ignored."
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
  [(PackageLocationImmutable, PackageIdentifier)]
locs1 <- [PackageIdentifierRevision]
-> (PackageIdentifierRevision
    -> RIO env (PackageLocationImmutable, PackageIdentifier))
-> RIO env [(PackageLocationImmutable, PackageIdentifier)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PackageIdentifierRevision]
pirs ((PackageIdentifierRevision
  -> RIO env (PackageLocationImmutable, PackageIdentifier))
 -> RIO env [(PackageLocationImmutable, PackageIdentifier)])
-> (PackageIdentifierRevision
    -> RIO env (PackageLocationImmutable, PackageIdentifier))
-> RIO env [(PackageLocationImmutable, PackageIdentifier)]
forall a b. (a -> b) -> a -> b
$ \PackageIdentifierRevision
pir -> do
    Text
hackageBaseUrl <- Getting Text env Text -> RIO env Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text env Text -> RIO env Text)
-> Getting Text env Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ (Config -> Const Text Config) -> env -> Const Text env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL ((Config -> Const Text Config) -> env -> Const Text env)
-> ((Text -> Const Text Text) -> Config -> Const Text Config)
-> Getting Text env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Text) -> SimpleGetter Config Text
forall s a. (s -> a) -> SimpleGetter s a
to (.hackageBaseUrl)
    let rpli :: RawPackageLocationImmutable
rpli = if Bool
areCandidates
          then
            let -- Ignoring revisions for package candidates.

                PackageIdentifierRevision PackageName
candidateName Version
candidateVersion CabalFileInfo
_ = PackageIdentifierRevision
pir
                candidatePkgId :: PackageIdentifier
candidatePkgId =
                  PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
candidateName Version
candidateVersion
                candidatePkgIdText :: Text
candidatePkgIdText =
                  String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
candidatePkgId
                candidateUrl :: Text
candidateUrl =
                     Text
hackageBaseUrl
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"package/"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
candidatePkgIdText
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/candidate/"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
candidatePkgIdText
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".tar.gz"
                candidateLoc :: ArchiveLocation
candidateLoc = Text -> ArchiveLocation
ALUrl Text
candidateUrl
                candidateArchive :: RawArchive
candidateArchive = ArchiveLocation
-> Maybe SHA256 -> Maybe FileSize -> Text -> RawArchive
RawArchive ArchiveLocation
candidateLoc Maybe SHA256
forall a. Maybe a
Nothing Maybe FileSize
forall a. Maybe a
Nothing Text
""
                candidateMetadata :: RawPackageMetadata
candidateMetadata = Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata Maybe PackageName
forall a. Maybe a
Nothing Maybe Version
forall a. Maybe a
Nothing Maybe TreeKey
forall a. Maybe a
Nothing
            in RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive
candidateArchive RawPackageMetadata
candidateMetadata
          else PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing
    PackageLocationImmutable
loc <- CompletePackageLocation -> PackageLocationImmutable
cplComplete (CompletePackageLocation -> PackageLocationImmutable)
-> RIO env CompletePackageLocation
-> RIO env PackageLocationImmutable
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 RawPackageLocationImmutable
rpli
      RIO env CompletePackageLocation
-> (SomeException -> RIO env CompletePackageLocation)
-> RIO env CompletePackageLocation
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
_ :: SomeException) -> UnpackPrettyException -> RIO env CompletePackageLocation
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (UnpackPrettyException -> RIO env CompletePackageLocation)
-> UnpackPrettyException -> RIO env CompletePackageLocation
forall a b. (a -> b) -> a -> b
$ PackageIdentifierRevision -> UnpackPrettyException
PackageLocationInvalid PackageIdentifierRevision
pir
    (PackageLocationImmutable, PackageIdentifier)
-> RIO env (PackageLocationImmutable, PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
loc, PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)
  ([StyleDoc]
errs, [(PackageLocationImmutable, PackageIdentifier)]
locs2) <- [Either StyleDoc (PackageLocationImmutable, PackageIdentifier)]
-> ([StyleDoc], [(PackageLocationImmutable, PackageIdentifier)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either StyleDoc (PackageLocationImmutable, PackageIdentifier)]
 -> ([StyleDoc], [(PackageLocationImmutable, PackageIdentifier)]))
-> RIO
     env [Either StyleDoc (PackageLocationImmutable, PackageIdentifier)]
-> RIO
     env ([StyleDoc], [(PackageLocationImmutable, PackageIdentifier)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName
 -> RIO
      env
      (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)))
-> [PackageName]
-> RIO
     env [Either StyleDoc (PackageLocationImmutable, PackageIdentifier)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLoc [PackageName]
names
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StyleDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StyleDoc]
errs) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ UnpackPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (UnpackPrettyException -> RIO env ())
-> UnpackPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> UnpackPrettyException
CouldNotParsePackageSelectors [StyleDoc]
errs
  Map PackageLocationImmutable (Path Abs Dir)
locs <- [(PackageLocationImmutable, Path Abs Dir)]
-> Map PackageLocationImmutable (Path Abs Dir)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageLocationImmutable, Path Abs Dir)]
 -> Map PackageLocationImmutable (Path Abs Dir))
-> RIO env [(PackageLocationImmutable, Path Abs Dir)]
-> RIO env (Map PackageLocationImmutable (Path Abs Dir))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PackageLocationImmutable, PackageIdentifier)
 -> RIO env (PackageLocationImmutable, Path Abs Dir))
-> [(PackageLocationImmutable, PackageIdentifier)]
-> RIO env [(PackageLocationImmutable, 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
    (\(PackageLocationImmutable
pir, PackageIdentifier
ident) -> do
        Path Rel Dir
suffix <- String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> RIO env (Path Rel Dir))
-> String -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
        (PackageLocationImmutable, Path Abs Dir)
-> RIO env (PackageLocationImmutable, Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
pir, Path Abs Dir
dest Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
suffix)
    )
    ([(PackageLocationImmutable, PackageIdentifier)]
locs1 [(PackageLocationImmutable, PackageIdentifier)]
-> [(PackageLocationImmutable, PackageIdentifier)]
-> [(PackageLocationImmutable, PackageIdentifier)]
forall a. [a] -> [a] -> [a]
++ [(PackageLocationImmutable, PackageIdentifier)]
locs2)

  [Path Abs Dir]
alreadyUnpacked <- (Path Abs Dir -> RIO env Bool)
-> [Path Abs Dir] -> RIO env [Path Abs Dir]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist ([Path Abs Dir] -> RIO env [Path Abs Dir])
-> [Path Abs Dir] -> RIO env [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ Map PackageLocationImmutable (Path Abs Dir) -> [Path Abs Dir]
forall k a. Map k a -> [a]
Map.elems Map PackageLocationImmutable (Path Abs Dir)
locs

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Path Abs Dir] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
alreadyUnpacked) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    UnpackPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (UnpackPrettyException -> RIO env ())
-> UnpackPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Set (Path Abs Dir) -> UnpackPrettyException
UnpackDirectoryAlreadyExists (Set (Path Abs Dir) -> UnpackPrettyException)
-> Set (Path Abs Dir) -> UnpackPrettyException
forall a b. (a -> b) -> a -> b
$ [Path Abs Dir] -> Set (Path Abs Dir)
forall a. Ord a => [a] -> Set a
Set.fromList [Path Abs Dir]
alreadyUnpacked

  [(PackageLocationImmutable, Path Abs Dir)]
-> ((PackageLocationImmutable, Path Abs Dir) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PackageLocationImmutable (Path Abs Dir)
-> [(PackageLocationImmutable, Path Abs Dir)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageLocationImmutable (Path Abs Dir)
locs) (((PackageLocationImmutable, Path Abs Dir) -> RIO env ())
 -> RIO env ())
-> ((PackageLocationImmutable, Path Abs Dir) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(PackageLocationImmutable
loc, Path Abs Dir
dest') -> do
    Path Abs Dir -> PackageLocationImmutable -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
dest' PackageLocationImmutable
loc
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      [ StyleDoc
"Unpacked"
      , String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Text
forall a. Display a => a -> Text
textDisplay PackageLocationImmutable
loc
      , StyleDoc
"to"
      , Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dest' StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
 where
  toLoc :: PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLoc PackageName
name | Just RawSnapshot
snapshot <- Maybe RawSnapshot
mSnapshot = RawSnapshot
-> PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLocSnapshot RawSnapshot
snapshot PackageName
name
             | Bool
otherwise = do
                 RIO env DidUpdateOccur -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env DidUpdateOccur -> RIO env ())
-> RIO env DidUpdateOccur -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just Utf8Builder
"Updating the package index."
                 PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLocNoSnapshot PackageName
name

  toLocNoSnapshot ::
       PackageName
    -> RIO env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
  toLocNoSnapshot :: PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLocNoSnapshot PackageName
name = do
    Maybe PackageLocationImmutable
mLoc <- RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation
      RequireHackageIndex
YesRequireHackageIndex
      PackageName
name
      UsePreferredVersions
UsePreferredVersions
    case Maybe PackageLocationImmutable
mLoc of
      Maybe PackageLocationImmutable
Nothing -> do
        [PackageName]
candidates <- PackageName -> RIO env [PackageName]
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name
        Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
 -> RIO
      env
      (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)))
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a b. (a -> b) -> a -> b
$ StyleDoc
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
forall a b. a -> Either a b
Left (StyleDoc
 -> Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
-> StyleDoc
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Could not find package"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name)
          , String -> StyleDoc
flow String
"on Hackage."
          , if [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
candidates
              then StyleDoc
forall a. Monoid a => a
mempty
              else [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                  String -> StyleDoc
flow String
"Perhaps you meant one of:"
                StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Good) Bool
False
                    ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName [PackageName]
candidates :: [StyleDoc])
          ]
      Just PackageLocationImmutable
loc -> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
 -> RIO
      env
      (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)))
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a b. (a -> b) -> a -> b
$ (PackageLocationImmutable, PackageIdentifier)
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
forall a b. b -> Either a b
Right (PackageLocationImmutable
loc, PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)

  toLocSnapshot ::
       RawSnapshot
    -> PackageName
    -> RIO env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
  toLocSnapshot :: RawSnapshot
-> PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLocSnapshot RawSnapshot
snapshot PackageName
name =
    case PackageName
-> Map PackageName RawSnapshotPackage -> Maybe RawSnapshotPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snapshot) of
      Maybe RawSnapshotPackage
Nothing ->
        Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
 -> RIO
      env
      (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)))
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a b. (a -> b) -> a -> b
$ StyleDoc
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
forall a b. a -> Either a b
Left (StyleDoc
 -> Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
-> StyleDoc
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Package does not appear in snapshot:"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      Just RawSnapshotPackage
sp -> do
        PackageLocationImmutable
loc <- CompletePackageLocation -> PackageLocationImmutable
cplComplete (CompletePackageLocation -> PackageLocationImmutable)
-> RIO env CompletePackageLocation
-> RIO env PackageLocationImmutable
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 (RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation RawSnapshotPackage
sp)
        Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
 -> RIO
      env
      (Either StyleDoc (PackageLocationImmutable, PackageIdentifier)))
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
forall a b. (a -> b) -> a -> b
$ (PackageLocationImmutable, PackageIdentifier)
-> Either StyleDoc (PackageLocationImmutable, PackageIdentifier)
forall a b. b -> Either a b
Right (PackageLocationImmutable
loc, PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)