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

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

module Stack.List
  ( listCmd
  , listPackages
  ) where

import           Pantry ( loadSnapshot )
import           RIO.List ( intercalate )
import qualified RIO.Map as Map
import           RIO.Process ( HasProcessContext )
import           Stack.Config ( makeConcreteResolver )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )

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

-- "Stack.List" module.

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

instance Exception ListException where
  displayException :: ListException -> String
displayException (CouldNotParsePackageSelectors [String]
strs) = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    String
"Error: [S-4926]"
    forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (String
"- " ++) [String]
strs

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

listCmd :: [String] -> RIO Runner ()
listCmd :: [String] -> RIO Runner ()
listCmd [String]
names = forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall a b. (a -> b) -> a -> b
$ do
  Maybe AbstractResolver
mresolver <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe AbstractResolver
globalResolver
  Maybe RawSnapshot
mSnapshot <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe AbstractResolver
mresolver forall a b. (a -> b) -> a -> b
$ \AbstractResolver
resolver -> do
    RawSnapshotLocation
concrete <- forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
resolver
    SnapshotLocation
loc <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation RawSnapshotLocation
concrete
    forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot SnapshotLocation
loc
  forall env.
(HasPantryConfig env, HasProcessContext env, HasTerm env) =>
Maybe RawSnapshot -> [String] -> RIO env ()
listPackages Maybe RawSnapshot
mSnapshot [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.

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

  -> RIO env ()
listPackages :: forall env.
(HasPantryConfig env, HasProcessContext env, HasTerm env) =>
Maybe RawSnapshot -> [String] -> RIO env ()
listPackages Maybe RawSnapshot
mSnapshot [String]
input = do
  let ([String]
errs1, [PackageName]
names) = case Maybe RawSnapshot
mSnapshot of
        Just RawSnapshot
snapshot | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
input -> ([], forall k a. Map k a -> [k]
Map.keys (RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snapshot))
        Maybe RawSnapshot
_ -> forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Either String PackageName
parse [String]
input
  ([String]
errs2, [PackageIdentifier]
locs) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse PackageName -> RIO env (Either String PackageIdentifier)
toLoc [PackageName]
names
  case [String]
errs1 forall a. [a] -> [a] -> [a]
++ [String]
errs2 of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [String]
errs -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [String] -> ListException
CouldNotParsePackageSelectors [String]
errs
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) [PackageIdentifier]
locs
 where
  toLoc :: PackageName -> RIO env (Either String PackageIdentifier)
toLoc | Just RawSnapshot
snapshot <- Maybe RawSnapshot
mSnapshot = RawSnapshot
-> PackageName -> RIO env (Either String PackageIdentifier)
toLocSnapshot RawSnapshot
snapshot
        | Bool
otherwise = PackageName -> RIO env (Either String PackageIdentifier)
toLocNoSnapshot

  toLocNoSnapshot :: PackageName -> RIO env (Either String PackageIdentifier)
  toLocNoSnapshot :: PackageName -> RIO env (Either String PackageIdentifier)
toLocNoSnapshot PackageName
name = do
    Maybe PackageLocationImmutable
mloc1 <-
      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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageLocationImmutable
mloc1
        Maybe PackageLocationImmutable
Nothing -> do
          DidUpdateOccur
updated <-
            forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
"Could not find package "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
name)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
          case DidUpdateOccur
updated of
            DidUpdateOccur
UpdateOccurred ->
              forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation
                RequireHackageIndex
YesRequireHackageIndex
                PackageName
name
                UsePreferredVersions
UsePreferredVersions
            DidUpdateOccur
NoUpdateOccurred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    case Maybe PackageLocationImmutable
mloc of
      Maybe PackageLocationImmutable
Nothing -> do
        [PackageName]
candidates <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ String
"Could not find package "
          , PackageName -> String
packageNameString PackageName
name
          , String
" on Hackage"
          , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
candidates
              then String
""
              else String
". Perhaps you meant: " forall a. [a] -> [a] -> [a]
++
                     forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
candidates)
          ]
      Just PackageLocationImmutable
loc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)

  toLocSnapshot ::
       RawSnapshot
    -> PackageName
    -> RIO env (Either String PackageIdentifier)
  toLocSnapshot :: RawSnapshot
-> PackageName -> RIO env (Either String PackageIdentifier)
toLocSnapshot RawSnapshot
snapshot PackageName
name =
    case 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 ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
          String
"Package does not appear in snapshot: " forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name
      Just RawSnapshotPackage
sp -> do
        PackageLocationImmutable
loc <- CompletePackageLocation -> PackageLocationImmutable
cplComplete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation (RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation RawSnapshotPackage
sp)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)

  parse :: String -> Either String PackageName
parse String
s =
    case String -> Maybe PackageName
parsePackageName String
s of
      Just PackageName
x -> forall a b. b -> Either a b
Right PackageName
x
      Maybe PackageName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Could not parse as package name or identifier: " forall a. [a] -> [a] -> [a]
++ String
s