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

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

module Stack.List
  ( listCmd
  , listPackages
  ) where

import qualified RIO.ByteString.Lazy as Lazy
import qualified RIO.Map as Map
import           RIO.Process ( HasProcessContext )
import           Stack.Config ( getRawSnapshot )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig )
import           Stack.SourceMap ( globalsFromHints )
import           Stack.Types.Runner ( Runner )

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

-- "Stack.List" module.

newtype ListPrettyException
  = CouldNotParsePackageSelectors [StyleDoc]
  deriving (Int -> ListPrettyException -> ShowS
[ListPrettyException] -> ShowS
ListPrettyException -> String
(Int -> ListPrettyException -> ShowS)
-> (ListPrettyException -> String)
-> ([ListPrettyException] -> ShowS)
-> Show ListPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListPrettyException -> ShowS
showsPrec :: Int -> ListPrettyException -> ShowS
$cshow :: ListPrettyException -> String
show :: ListPrettyException -> String
$cshowList :: [ListPrettyException] -> ShowS
showList :: [ListPrettyException] -> ShowS
Show, Typeable)

instance Pretty ListPrettyException where
  pretty :: ListPrettyException -> StyleDoc
pretty (CouldNotParsePackageSelectors [StyleDoc]
errs) =
    StyleDoc
"[S-4926]"
    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

instance Exception ListPrettyException

-- | Function underlying the @stack list@ command. List packages.

listCmd :: [String] -> RIO Runner ()
listCmd :: [String] -> RIO Runner ()
listCmd [String]
names = 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 RawSnapshot
mSnapshot <- RIO Config (Maybe RawSnapshot)
forall env. HasConfig env => RIO env (Maybe RawSnapshot)
getRawSnapshot
  let mWc :: Maybe WantedCompiler
mWc = RawSnapshot -> WantedCompiler
rsCompiler (RawSnapshot -> WantedCompiler)
-> Maybe RawSnapshot -> Maybe WantedCompiler
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RawSnapshot
mSnapshot
  Maybe (Map PackageName Version)
mGlobals <- (WantedCompiler -> RIO Config (Map PackageName Version))
-> Maybe WantedCompiler
-> RIO Config (Maybe (Map PackageName Version))
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) -> Maybe a -> m (Maybe b)
mapM WantedCompiler -> RIO Config (Map PackageName Version)
forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints Maybe WantedCompiler
mWc
  Maybe RawSnapshot
-> Maybe (Map PackageName Version) -> [String] -> RIO Config ()
forall env.
(HasPantryConfig env, HasProcessContext env, HasTerm env) =>
Maybe RawSnapshot
-> Maybe (Map PackageName Version) -> [String] -> RIO env ()
listPackages Maybe RawSnapshot
mSnapshot Maybe (Map PackageName Version)
mGlobals [String]
names

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

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

  -> Maybe (Map PackageName Version)
     -- ^ Global hints for snapshot wanted compiler.

  -> [String]
     -- ^ Names or identifiers.

  -> RIO env ()
listPackages :: forall env.
(HasPantryConfig env, HasProcessContext env, HasTerm env) =>
Maybe RawSnapshot
-> Maybe (Map PackageName Version) -> [String] -> RIO env ()
listPackages Maybe RawSnapshot
mSnapshot Maybe (Map PackageName Version)
mGlobals [String]
input = do
  let ([StyleDoc]
errs1, [PackageName]
names) = case Maybe RawSnapshot
mSnapshot of
        Just RawSnapshot
snapshot | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
input -> ([], Map PackageName RawSnapshotPackage -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snapshot))
        Maybe RawSnapshot
_ -> [Either StyleDoc PackageName] -> ([StyleDoc], [PackageName])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either StyleDoc PackageName] -> ([StyleDoc], [PackageName]))
-> [Either StyleDoc PackageName] -> ([StyleDoc], [PackageName])
forall a b. (a -> b) -> a -> b
$ (String -> Either StyleDoc PackageName)
-> [String] -> [Either StyleDoc PackageName]
forall a b. (a -> b) -> [a] -> [b]
map String -> Either StyleDoc PackageName
parse [String]
input
  ([StyleDoc]
errs2, [PackageIdentifier]
locs) <- [Either StyleDoc PackageIdentifier]
-> ([StyleDoc], [PackageIdentifier])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either StyleDoc PackageIdentifier]
 -> ([StyleDoc], [PackageIdentifier]))
-> RIO env [Either StyleDoc PackageIdentifier]
-> RIO env ([StyleDoc], [PackageIdentifier])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName -> RIO env (Either StyleDoc PackageIdentifier))
-> [PackageName] -> RIO env [Either StyleDoc 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 PackageIdentifier)
toLoc [PackageName]
names
  case [StyleDoc]
errs1 [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++ [StyleDoc]
errs2 of
    [] -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [StyleDoc]
errs -> ListPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (ListPrettyException -> RIO env ())
-> ListPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> ListPrettyException
CouldNotParsePackageSelectors [StyleDoc]
errs
  (PackageIdentifier -> RIO env ())
-> [PackageIdentifier] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LByteString -> RIO env ()
forall (m :: * -> *). MonadIO m => LByteString -> m ()
Lazy.putStrLn (LByteString -> RIO env ())
-> (PackageIdentifier -> LByteString)
-> PackageIdentifier
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> LByteString
forall a. IsString a => PackageIdentifier -> a
fromPackageId) [PackageIdentifier]
locs
 where
  toLoc :: PackageName -> RIO env (Either StyleDoc PackageIdentifier)
toLoc | Just RawSnapshot
snapshot <- Maybe RawSnapshot
mSnapshot = RawSnapshot
-> PackageName -> RIO env (Either StyleDoc PackageIdentifier)
toLocSnapshot RawSnapshot
snapshot
        | Bool
otherwise = PackageName -> RIO env (Either StyleDoc PackageIdentifier)
toLocNoSnapshot

  toLocNoSnapshot :: PackageName -> RIO env (Either StyleDoc PackageIdentifier)
  toLocNoSnapshot :: PackageName -> RIO env (Either StyleDoc PackageIdentifier)
toLocNoSnapshot PackageName
name = do
    Maybe PackageLocationImmutable
mloc1 <-
      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
    Maybe PackageLocationImmutable
mloc <-
      case Maybe PackageLocationImmutable
mloc1 of
        Just PackageLocationImmutable
_ -> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageLocationImmutable
mloc1
        Maybe PackageLocationImmutable
Nothing -> do
          DidUpdateOccur
updated <-
            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 -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
"Could not find package "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
          case DidUpdateOccur
updated of
            DidUpdateOccur
UpdateOccurred ->
              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
            DidUpdateOccur
NoUpdateOccurred -> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
    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 PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc PackageIdentifier
 -> RIO env (Either StyleDoc PackageIdentifier))
-> Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc PackageIdentifier
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc PackageIdentifier)
-> StyleDoc -> Either StyleDoc 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 PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc PackageIdentifier
 -> RIO env (Either StyleDoc PackageIdentifier))
-> Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Either StyleDoc PackageIdentifier
forall a b. b -> Either a b
Right (PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)

  toLocSnapshot ::
       RawSnapshot
    -> PackageName
    -> RIO env (Either StyleDoc PackageIdentifier)
  toLocSnapshot :: RawSnapshot
-> PackageName -> RIO env (Either StyleDoc 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 -> case PackageName -> Map PackageName Version -> Maybe Version
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (Map PackageName Version -> Maybe Version)
-> Maybe (Map PackageName Version) -> Maybe Version
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Map PackageName Version)
mGlobals of
        Maybe Version
Nothing -> 
          Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc PackageIdentifier
 -> RIO env (Either StyleDoc PackageIdentifier))
-> Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc PackageIdentifier
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc PackageIdentifier)
-> StyleDoc -> Either StyleDoc PackageIdentifier
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
            [ String -> StyleDoc
flow String
"Package does not appear in snapshot (directly or \
                   \indirectly):"
            , 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 Version
version ->
          Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc PackageIdentifier
 -> RIO env (Either StyleDoc PackageIdentifier))
-> Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Either StyleDoc PackageIdentifier
forall a b. b -> Either a b
Right (PackageIdentifier -> Either StyleDoc PackageIdentifier)
-> PackageIdentifier -> Either StyleDoc PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
      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 PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc PackageIdentifier
 -> RIO env (Either StyleDoc PackageIdentifier))
-> Either StyleDoc PackageIdentifier
-> RIO env (Either StyleDoc PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Either StyleDoc PackageIdentifier
forall a b. b -> Either a b
Right (PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)

  parse :: String -> Either StyleDoc PackageName
parse String
s =
    case String -> Maybe PackageName
parsePackageName String
s of
      Just PackageName
x -> PackageName -> Either StyleDoc PackageName
forall a b. b -> Either a b
Right PackageName
x
      Maybe PackageName
Nothing -> StyleDoc -> Either StyleDoc PackageName
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc PackageName)
-> StyleDoc -> Either StyleDoc PackageName
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
        [ String -> StyleDoc
flow String
"Could not parse as package name or identifier:"
        , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
s) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]