{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.List
  ( listPackages
  ) where

import Stack.Prelude
import qualified RIO.Map as Map
import RIO.List (intercalate)
import RIO.Process (HasProcessContext)

newtype ListException
  = CouldNotParsePackageSelectors [String]
    deriving Typeable
instance Exception ListException
instance Show ListException where
    show :: ListException -> String
show (CouldNotParsePackageSelectors [String]
strs) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
strs

-- | Intended to work for the command line command.
listPackages
  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Maybe RawSnapshot -- ^ when looking up by name, take from this build plan
  -> [String] -- ^ names or identifiers
  -> RIO env ()
listPackages :: 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 | [String] -> 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 String PackageName] -> ([String], [PackageName])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String PackageName] -> ([String], [PackageName]))
-> [Either String PackageName] -> ([String], [PackageName])
forall a b. (a -> b) -> a -> b
$ (String -> Either String PackageName)
-> [String] -> [Either String PackageName]
forall a b. (a -> b) -> [a] -> [b]
map String -> Either String PackageName
parse [String]
input
    ([String]
errs2, [PackageIdentifier]
locs) <- [Either String PackageIdentifier]
-> ([String], [PackageIdentifier])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String PackageIdentifier]
 -> ([String], [PackageIdentifier]))
-> RIO env [Either String PackageIdentifier]
-> RIO env ([String], [PackageIdentifier])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName -> RIO env (Either String PackageIdentifier))
-> [PackageName] -> RIO env [Either String PackageIdentifier]
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
errs2 of
      [] -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      [String]
errs -> ListException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ListException -> RIO env ()) -> ListException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [String] -> ListException
CouldNotParsePackageSelectors [String]
errs
    (PackageIdentifier -> RIO env ())
-> [PackageIdentifier] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (PackageIdentifier -> Utf8Builder)
-> PackageIdentifier
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder)
-> (PackageIdentifier -> String)
-> PackageIdentifier
-> Utf8Builder
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 <- 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 (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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString 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 (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 String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String PackageIdentifier
 -> RIO env (Either String PackageIdentifier))
-> Either String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ String -> Either String PackageIdentifier
forall a b. a -> Either a b
Left (String -> Either String PackageIdentifier)
-> String -> Either String PackageIdentifier
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Could not find package "
            , PackageName -> String
packageNameString PackageName
name
            , String
" on Hackage"
            , if [PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
candidates
                then String
""
                else String
". Perhaps you meant: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
candidates)
            ]
        Just PackageLocationImmutable
loc -> Either String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String PackageIdentifier
 -> RIO env (Either String PackageIdentifier))
-> Either String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Either String PackageIdentifier
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 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 String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String PackageIdentifier
 -> RIO env (Either String PackageIdentifier))
-> Either String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ String -> Either String PackageIdentifier
forall a b. a -> Either a b
Left (String -> Either String PackageIdentifier)
-> String -> Either String PackageIdentifier
forall a b. (a -> b) -> a -> b
$ String
"Package does not appear in snapshot: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name
          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 String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String PackageIdentifier
 -> RIO env (Either String PackageIdentifier))
-> Either String PackageIdentifier
-> RIO env (Either String PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Either String PackageIdentifier
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 -> PackageName -> Either String PackageName
forall a b. b -> Either a b
Right PackageName
x
            Maybe PackageName
Nothing -> String -> Either String PackageName
forall a b. a -> Either a b
Left (String -> Either String PackageName)
-> String -> Either String PackageName
forall a b. (a -> b) -> a -> b
$ String
"Could not parse as package name or identifier: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s