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

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

module Stack.Ls
  ( LsCmdOpts (..)
  , LsCmds (..)
  , SnapshotOpts (..)
  , ListStylesOpts (..)
  , ListToolsOpts (..)
  , LsView (..)
  , lsCmd
  ) where

import           Data.Aeson ( FromJSON, Value (..), (.:) )
import           Data.Array.IArray ( (//), elems )
import           Distribution.Package ( mkPackageName )
import qualified Data.Aeson.Types as A
import qualified Data.List as L
import           Data.Text hiding ( filter, intercalate, pack, reverse )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Vector as V
import           Network.HTTP.StackClient
                   ( addRequestHeader, hAccept, httpJSON, getResponseBody
                   , parseRequest
                   )
import           Path ( parent )
import           RIO.List ( sort )
import           Stack.Constants ( osIsWindows )
import           Stack.Dot ( ListDepsOpts, listDependencies )
import           Stack.Prelude hiding ( Nightly, Snapshot )
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.Setup.Installed
                   ( Tool (..), filterTools, listInstalled, toolString )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.EnvConfig ( installationRootDeps )
import           Stack.Types.Runner ( HasRunner, Runner, terminalL )
import           System.Console.ANSI.Codes
                   ( SGR (Reset), setSGRCode, sgrToCode )
import           System.Process.Pager ( pageText )
import           System.Directory ( listDirectory )
import           System.IO ( putStrLn )

-- | Type representing exceptions thrown by functions exported by the "Stack.Ls"

-- module.

newtype LsException
  = ParseFailure [Value]
  deriving (Int -> LsException -> ShowS
[LsException] -> ShowS
LsException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LsException] -> ShowS
$cshowList :: [LsException] -> ShowS
show :: LsException -> [Char]
$cshow :: LsException -> [Char]
showsPrec :: Int -> LsException -> ShowS
$cshowsPrec :: Int -> LsException -> ShowS
Show, Typeable)

instance Exception LsException where
  displayException :: LsException -> [Char]
displayException (ParseFailure [Value]
val) =
    [Char]
"Error: [S-3421]\n"
    forall a. [a] -> [a] -> [a]
++ [Char]
"Failure to parse values as a snapshot: "
    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Value]
val

-- | Type representing subcommands for the @stack ls snapshots@ command.

data LsView
  = Local
  | Remote
  deriving (LsView -> LsView -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LsView -> LsView -> Bool
$c/= :: LsView -> LsView -> Bool
== :: LsView -> LsView -> Bool
$c== :: LsView -> LsView -> Bool
Eq, Eq LsView
LsView -> LsView -> Bool
LsView -> LsView -> Ordering
LsView -> LsView -> LsView
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LsView -> LsView -> LsView
$cmin :: LsView -> LsView -> LsView
max :: LsView -> LsView -> LsView
$cmax :: LsView -> LsView -> LsView
>= :: LsView -> LsView -> Bool
$c>= :: LsView -> LsView -> Bool
> :: LsView -> LsView -> Bool
$c> :: LsView -> LsView -> Bool
<= :: LsView -> LsView -> Bool
$c<= :: LsView -> LsView -> Bool
< :: LsView -> LsView -> Bool
$c< :: LsView -> LsView -> Bool
compare :: LsView -> LsView -> Ordering
$ccompare :: LsView -> LsView -> Ordering
Ord, Int -> LsView -> ShowS
[LsView] -> ShowS
LsView -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LsView] -> ShowS
$cshowList :: [LsView] -> ShowS
show :: LsView -> [Char]
$cshow :: LsView -> [Char]
showsPrec :: Int -> LsView -> ShowS
$cshowsPrec :: Int -> LsView -> ShowS
Show)

-- | Type representing Stackage snapshot types.

data SnapshotType
  = Lts
    -- ^ Stackage LTS Haskell

  | Nightly
    -- ^ Stackage Nightly

  deriving (SnapshotType -> SnapshotType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotType -> SnapshotType -> Bool
$c/= :: SnapshotType -> SnapshotType -> Bool
== :: SnapshotType -> SnapshotType -> Bool
$c== :: SnapshotType -> SnapshotType -> Bool
Eq, Eq SnapshotType
SnapshotType -> SnapshotType -> Bool
SnapshotType -> SnapshotType -> Ordering
SnapshotType -> SnapshotType -> SnapshotType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapshotType -> SnapshotType -> SnapshotType
$cmin :: SnapshotType -> SnapshotType -> SnapshotType
max :: SnapshotType -> SnapshotType -> SnapshotType
$cmax :: SnapshotType -> SnapshotType -> SnapshotType
>= :: SnapshotType -> SnapshotType -> Bool
$c>= :: SnapshotType -> SnapshotType -> Bool
> :: SnapshotType -> SnapshotType -> Bool
$c> :: SnapshotType -> SnapshotType -> Bool
<= :: SnapshotType -> SnapshotType -> Bool
$c<= :: SnapshotType -> SnapshotType -> Bool
< :: SnapshotType -> SnapshotType -> Bool
$c< :: SnapshotType -> SnapshotType -> Bool
compare :: SnapshotType -> SnapshotType -> Ordering
$ccompare :: SnapshotType -> SnapshotType -> Ordering
Ord, Int -> SnapshotType -> ShowS
[SnapshotType] -> ShowS
SnapshotType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotType] -> ShowS
$cshowList :: [SnapshotType] -> ShowS
show :: SnapshotType -> [Char]
$cshow :: SnapshotType -> [Char]
showsPrec :: Int -> SnapshotType -> ShowS
$cshowsPrec :: Int -> SnapshotType -> ShowS
Show)

-- | Type representing command line options for the @stack ls snapshots@

-- command.

data SnapshotOpts = SnapshotOpts
  { SnapshotOpts -> LsView
soptViewType :: LsView
  , SnapshotOpts -> Bool
soptLtsSnapView :: Bool
  , SnapshotOpts -> Bool
soptNightlySnapView :: Bool
  }
  deriving (SnapshotOpts -> SnapshotOpts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotOpts -> SnapshotOpts -> Bool
$c/= :: SnapshotOpts -> SnapshotOpts -> Bool
== :: SnapshotOpts -> SnapshotOpts -> Bool
$c== :: SnapshotOpts -> SnapshotOpts -> Bool
Eq, Eq SnapshotOpts
SnapshotOpts -> SnapshotOpts -> Bool
SnapshotOpts -> SnapshotOpts -> Ordering
SnapshotOpts -> SnapshotOpts -> SnapshotOpts
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapshotOpts -> SnapshotOpts -> SnapshotOpts
$cmin :: SnapshotOpts -> SnapshotOpts -> SnapshotOpts
max :: SnapshotOpts -> SnapshotOpts -> SnapshotOpts
$cmax :: SnapshotOpts -> SnapshotOpts -> SnapshotOpts
>= :: SnapshotOpts -> SnapshotOpts -> Bool
$c>= :: SnapshotOpts -> SnapshotOpts -> Bool
> :: SnapshotOpts -> SnapshotOpts -> Bool
$c> :: SnapshotOpts -> SnapshotOpts -> Bool
<= :: SnapshotOpts -> SnapshotOpts -> Bool
$c<= :: SnapshotOpts -> SnapshotOpts -> Bool
< :: SnapshotOpts -> SnapshotOpts -> Bool
$c< :: SnapshotOpts -> SnapshotOpts -> Bool
compare :: SnapshotOpts -> SnapshotOpts -> Ordering
$ccompare :: SnapshotOpts -> SnapshotOpts -> Ordering
Ord, Int -> SnapshotOpts -> ShowS
[SnapshotOpts] -> ShowS
SnapshotOpts -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotOpts] -> ShowS
$cshowList :: [SnapshotOpts] -> ShowS
show :: SnapshotOpts -> [Char]
$cshow :: SnapshotOpts -> [Char]
showsPrec :: Int -> SnapshotOpts -> ShowS
$cshowsPrec :: Int -> SnapshotOpts -> ShowS
Show)

-- | Type representing command line options for the @stack ls stack-colors@ and

-- @stack ls stack-colours@ commands.

data ListStylesOpts = ListStylesOpts
  { ListStylesOpts -> Bool
coptBasic   :: Bool
  , ListStylesOpts -> Bool
coptSGR     :: Bool
  , ListStylesOpts -> Bool
coptExample :: Bool
  }
  deriving (ListStylesOpts -> ListStylesOpts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListStylesOpts -> ListStylesOpts -> Bool
$c/= :: ListStylesOpts -> ListStylesOpts -> Bool
== :: ListStylesOpts -> ListStylesOpts -> Bool
$c== :: ListStylesOpts -> ListStylesOpts -> Bool
Eq, Eq ListStylesOpts
ListStylesOpts -> ListStylesOpts -> Bool
ListStylesOpts -> ListStylesOpts -> Ordering
ListStylesOpts -> ListStylesOpts -> ListStylesOpts
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ListStylesOpts -> ListStylesOpts -> ListStylesOpts
$cmin :: ListStylesOpts -> ListStylesOpts -> ListStylesOpts
max :: ListStylesOpts -> ListStylesOpts -> ListStylesOpts
$cmax :: ListStylesOpts -> ListStylesOpts -> ListStylesOpts
>= :: ListStylesOpts -> ListStylesOpts -> Bool
$c>= :: ListStylesOpts -> ListStylesOpts -> Bool
> :: ListStylesOpts -> ListStylesOpts -> Bool
$c> :: ListStylesOpts -> ListStylesOpts -> Bool
<= :: ListStylesOpts -> ListStylesOpts -> Bool
$c<= :: ListStylesOpts -> ListStylesOpts -> Bool
< :: ListStylesOpts -> ListStylesOpts -> Bool
$c< :: ListStylesOpts -> ListStylesOpts -> Bool
compare :: ListStylesOpts -> ListStylesOpts -> Ordering
$ccompare :: ListStylesOpts -> ListStylesOpts -> Ordering
Ord, Int -> ListStylesOpts -> ShowS
[ListStylesOpts] -> ShowS
ListStylesOpts -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ListStylesOpts] -> ShowS
$cshowList :: [ListStylesOpts] -> ShowS
show :: ListStylesOpts -> [Char]
$cshow :: ListStylesOpts -> [Char]
showsPrec :: Int -> ListStylesOpts -> ShowS
$cshowsPrec :: Int -> ListStylesOpts -> ShowS
Show)

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

newtype ListToolsOpts
  = ListToolsOpts { ListToolsOpts -> [Char]
toptFilter  :: String }

-- | Type representing subcommands for the @stack ls@ command.

data LsCmds
  = LsSnapshot SnapshotOpts
  | LsDependencies ListDepsOpts
  | LsStyles ListStylesOpts
  | LsTools ListToolsOpts

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

newtype LsCmdOpts
  = LsCmdOpts { LsCmdOpts -> LsCmds
lsView :: LsCmds }

data Snapshot = Snapshot
  { Snapshot -> Text
snapId :: Text
  , Snapshot -> Text
snapTitle :: Text
  , Snapshot -> Text
snapTime :: Text
  }
  deriving (Snapshot -> Snapshot -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Snapshot -> Snapshot -> Bool
$c/= :: Snapshot -> Snapshot -> Bool
== :: Snapshot -> Snapshot -> Bool
$c== :: Snapshot -> Snapshot -> Bool
Eq, Eq Snapshot
Snapshot -> Snapshot -> Bool
Snapshot -> Snapshot -> Ordering
Snapshot -> Snapshot -> Snapshot
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Snapshot -> Snapshot -> Snapshot
$cmin :: Snapshot -> Snapshot -> Snapshot
max :: Snapshot -> Snapshot -> Snapshot
$cmax :: Snapshot -> Snapshot -> Snapshot
>= :: Snapshot -> Snapshot -> Bool
$c>= :: Snapshot -> Snapshot -> Bool
> :: Snapshot -> Snapshot -> Bool
$c> :: Snapshot -> Snapshot -> Bool
<= :: Snapshot -> Snapshot -> Bool
$c<= :: Snapshot -> Snapshot -> Bool
< :: Snapshot -> Snapshot -> Bool
$c< :: Snapshot -> Snapshot -> Bool
compare :: Snapshot -> Snapshot -> Ordering
$ccompare :: Snapshot -> Snapshot -> Ordering
Ord, Int -> Snapshot -> ShowS
[Snapshot] -> ShowS
Snapshot -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Snapshot] -> ShowS
$cshowList :: [Snapshot] -> ShowS
show :: Snapshot -> [Char]
$cshow :: Snapshot -> [Char]
showsPrec :: Int -> Snapshot -> ShowS
$cshowsPrec :: Int -> Snapshot -> ShowS
Show)

data SnapshotData = SnapshotData
  { SnapshotData -> Integer
_snapTotalCounts :: Integer
  , SnapshotData -> [[Snapshot]]
snaps :: [[Snapshot]]
  }
  deriving (SnapshotData -> SnapshotData -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotData -> SnapshotData -> Bool
$c/= :: SnapshotData -> SnapshotData -> Bool
== :: SnapshotData -> SnapshotData -> Bool
$c== :: SnapshotData -> SnapshotData -> Bool
Eq, Eq SnapshotData
SnapshotData -> SnapshotData -> Bool
SnapshotData -> SnapshotData -> Ordering
SnapshotData -> SnapshotData -> SnapshotData
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapshotData -> SnapshotData -> SnapshotData
$cmin :: SnapshotData -> SnapshotData -> SnapshotData
max :: SnapshotData -> SnapshotData -> SnapshotData
$cmax :: SnapshotData -> SnapshotData -> SnapshotData
>= :: SnapshotData -> SnapshotData -> Bool
$c>= :: SnapshotData -> SnapshotData -> Bool
> :: SnapshotData -> SnapshotData -> Bool
$c> :: SnapshotData -> SnapshotData -> Bool
<= :: SnapshotData -> SnapshotData -> Bool
$c<= :: SnapshotData -> SnapshotData -> Bool
< :: SnapshotData -> SnapshotData -> Bool
$c< :: SnapshotData -> SnapshotData -> Bool
compare :: SnapshotData -> SnapshotData -> Ordering
$ccompare :: SnapshotData -> SnapshotData -> Ordering
Ord, Int -> SnapshotData -> ShowS
[SnapshotData] -> ShowS
SnapshotData -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotData] -> ShowS
$cshowList :: [SnapshotData] -> ShowS
show :: SnapshotData -> [Char]
$cshow :: SnapshotData -> [Char]
showsPrec :: Int -> SnapshotData -> ShowS
$cshowsPrec :: Int -> SnapshotData -> ShowS
Show)

instance FromJSON Snapshot where
  parseJSON :: Value -> Parser Snapshot
parseJSON o :: Value
o@(Array Array
_) = Value -> Parser Snapshot
parseSnapshot Value
o
  parseJSON Value
_ = forall a. Monoid a => a
mempty

instance FromJSON SnapshotData where
  parseJSON :: Value -> Parser SnapshotData
parseJSON (Object Object
s) =
    Integer -> [[Snapshot]] -> SnapshotData
SnapshotData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
s forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"totalCount" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
s forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"snapshots"
  parseJSON Value
_ = forall a. Monoid a => a
mempty

toSnapshot :: [Value] -> Snapshot
toSnapshot :: [Value] -> Snapshot
toSnapshot [String Text
sid, String Text
stitle, String Text
stime] =
  Snapshot
    { snapId :: Text
snapId = Text
sid
    , snapTitle :: Text
snapTitle = Text
stitle
    , snapTime :: Text
snapTime = Text
stime
    }
toSnapshot [Value]
val = forall e a. Exception e => e -> a
impureThrow forall a b. (a -> b) -> a -> b
$ [Value] -> LsException
ParseFailure [Value]
val

parseSnapshot :: Value -> A.Parser Snapshot
parseSnapshot :: Value -> Parser Snapshot
parseSnapshot = forall a. [Char] -> (Array -> Parser a) -> Value -> Parser a
A.withArray [Char]
"array of snapshot" (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Snapshot
toSnapshot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
V.toList)

displayTime :: Snapshot -> [Text]
displayTime :: Snapshot -> [Text]
displayTime Snapshot {Text
snapTime :: Text
snapTitle :: Text
snapId :: Text
snapTime :: Snapshot -> Text
snapTitle :: Snapshot -> Text
snapId :: Snapshot -> Text
..} = [Text
snapTime]

displaySnap :: Snapshot -> [Text]
displaySnap :: Snapshot -> [Text]
displaySnap Snapshot {Text
snapTime :: Text
snapTitle :: Text
snapId :: Text
snapTime :: Snapshot -> Text
snapTitle :: Snapshot -> Text
snapId :: Snapshot -> Text
..} =
  [Text
"Resolver name: " forall a. Semigroup a => a -> a -> a
<> Text
snapId, Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
snapTitle forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"]

displaySingleSnap :: [Snapshot] -> Text
displaySingleSnap :: [Snapshot] -> Text
displaySingleSnap [Snapshot]
snapshots =
  case [Snapshot]
snapshots of
    [] -> forall a. Monoid a => a
mempty
    (Snapshot
x:[Snapshot]
xs) ->
      let snaps :: [Text]
snaps =
            Snapshot -> [Text]
displayTime Snapshot
x forall a. Semigroup a => a -> a -> a
<> [Text
"\n\n"] forall a. Semigroup a => a -> a -> a
<> Snapshot -> [Text]
displaySnap Snapshot
x forall a. Semigroup a => a -> a -> a
<>
            forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap Snapshot -> [Text]
displaySnap [Snapshot]
xs
      in  [Text] -> Text
T.concat [Text]
snaps

renderData :: Bool -> Text -> IO ()
renderData :: Bool -> Text -> IO ()
renderData Bool
True Text
content = Text -> IO ()
pageText Text
content
renderData Bool
False Text
content = Text -> IO ()
T.putStr Text
content

displaySnapshotData :: Bool -> SnapshotData -> IO ()
displaySnapshotData :: Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
term SnapshotData
sdata =
  case forall a. [a] -> [a]
L.reverse forall a b. (a -> b) -> a -> b
$ SnapshotData -> [[Snapshot]]
snaps SnapshotData
sdata of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [[Snapshot]]
xs ->
      let snaps :: Text
snaps = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
L.map [Snapshot] -> Text
displaySingleSnap [[Snapshot]]
xs
      in  Bool -> Text -> IO ()
renderData Bool
term Text
snaps

filterSnapshotData :: SnapshotData -> SnapshotType -> SnapshotData
filterSnapshotData :: SnapshotData -> SnapshotType -> SnapshotData
filterSnapshotData SnapshotData
sdata SnapshotType
stype =
  SnapshotData
sdata { snaps :: [[Snapshot]]
snaps = [[Snapshot]]
filterSnapData }
 where
  snapdata :: [[Snapshot]]
snapdata = SnapshotData -> [[Snapshot]]
snaps SnapshotData
sdata
  filterSnapData :: [[Snapshot]]
filterSnapData =
    case SnapshotType
stype of
      SnapshotType
Lts -> forall a b. (a -> b) -> [a] -> [b]
L.map (forall a. (a -> Bool) -> [a] -> [a]
L.filter (\Snapshot
x -> Text
"lts" Text -> Text -> Bool
`isPrefixOf` Snapshot -> Text
snapId Snapshot
x)) [[Snapshot]]
snapdata
      SnapshotType
Nightly ->
        forall a b. (a -> b) -> [a] -> [b]
L.map (forall a. (a -> Bool) -> [a] -> [a]
L.filter (\Snapshot
x -> Text
"nightly" Text -> Text -> Bool
`isPrefixOf` Snapshot -> Text
snapId Snapshot
x)) [[Snapshot]]
snapdata

displayLocalSnapshot :: Bool -> [String] -> IO ()
displayLocalSnapshot :: Bool -> [[Char]] -> IO ()
displayLocalSnapshot Bool
term [[Char]]
xs = Bool -> Text -> IO ()
renderData Bool
term ([[Char]] -> Text
localSnaptoText [[Char]]
xs)

localSnaptoText :: [String] -> Text
localSnaptoText :: [[Char]] -> Text
localSnaptoText [[Char]]
xs = Text -> [Text] -> Text
T.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
L.map [Char] -> Text
T.pack [[Char]]
xs

handleLocal :: LsCmdOpts -> RIO Runner ()
handleLocal :: LsCmdOpts -> RIO Runner ()
handleLocal LsCmdOpts
lsOpts = do
  (Path Abs Dir
instRoot :: Path Abs Dir) <-
    forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
  Bool
isStdoutTerminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL
  let parentInstRoot :: Path Abs Dir
parentInstRoot = forall b t. Path b t -> Path b Dir
parent Path Abs Dir
instRoot
      snapRootDir :: Path Abs Dir
snapRootDir
        | Bool
osIsWindows = Path Abs Dir
parentInstRoot
        | Bool
otherwise   = forall b t. Path b t -> Path b Dir
parent Path Abs Dir
parentInstRoot
  [[Char]]
snapData' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectory forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
snapRootDir
  let snapData :: [[Char]]
snapData = forall a. Ord a => [a] -> [a]
L.sort [[Char]]
snapData'
  case LsCmdOpts -> LsCmds
lsView LsCmdOpts
lsOpts of
    LsSnapshot SnapshotOpts {Bool
LsView
soptNightlySnapView :: Bool
soptLtsSnapView :: Bool
soptViewType :: LsView
soptNightlySnapView :: SnapshotOpts -> Bool
soptLtsSnapView :: SnapshotOpts -> Bool
soptViewType :: SnapshotOpts -> LsView
..} ->
      case (Bool
soptLtsSnapView, Bool
soptNightlySnapView) of
        (Bool
True, Bool
False) ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          Bool -> [[Char]] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal forall a b. (a -> b) -> a -> b
$
          forall a. (a -> Bool) -> [a] -> [a]
L.filter (forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf [Char]
"lts") [[Char]]
snapData
        (Bool
False, Bool
True) ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          Bool -> [[Char]] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal forall a b. (a -> b) -> a -> b
$
          forall a. (a -> Bool) -> [a] -> [a]
L.filter (forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf [Char]
"night") [[Char]]
snapData
        (Bool, Bool)
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [[Char]] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal [[Char]]
snapData
    LsDependencies ListDepsOpts
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    LsStyles ListStylesOpts
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    LsTools ListToolsOpts
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleRemote :: HasRunner env => LsCmdOpts -> RIO env ()
handleRemote :: forall env. HasRunner env => LsCmdOpts -> RIO env ()
handleRemote LsCmdOpts
lsOpts = do
  Request
req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
urlInfo
  Bool
isStdoutTerminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL
  let req' :: Request
req' = HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAccept ByteString
"application/json" Request
req
  Response SnapshotData
result <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
req'
  let snapData :: SnapshotData
snapData = forall a. Response a -> a
getResponseBody Response SnapshotData
result
  case LsCmdOpts -> LsCmds
lsView LsCmdOpts
lsOpts of
    LsSnapshot SnapshotOpts {Bool
LsView
soptNightlySnapView :: Bool
soptLtsSnapView :: Bool
soptViewType :: LsView
soptNightlySnapView :: SnapshotOpts -> Bool
soptLtsSnapView :: SnapshotOpts -> Bool
soptViewType :: SnapshotOpts -> LsView
..} ->
      case (Bool
soptLtsSnapView, Bool
soptNightlySnapView) of
        (Bool
True, Bool
False) ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
isStdoutTerminal forall a b. (a -> b) -> a -> b
$
          SnapshotData -> SnapshotType -> SnapshotData
filterSnapshotData SnapshotData
snapData SnapshotType
Lts
        (Bool
False, Bool
True) ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
isStdoutTerminal forall a b. (a -> b) -> a -> b
$
          SnapshotData -> SnapshotType -> SnapshotData
filterSnapshotData SnapshotData
snapData SnapshotType
Nightly
        (Bool, Bool)
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
isStdoutTerminal SnapshotData
snapData
    LsDependencies ListDepsOpts
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    LsStyles ListStylesOpts
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    LsTools ListToolsOpts
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  urlInfo :: [Char]
urlInfo = [Char]
"https://www.stackage.org/snapshots"

lsCmd :: LsCmdOpts -> RIO Runner ()
lsCmd :: LsCmdOpts -> RIO Runner ()
lsCmd LsCmdOpts
lsOpts =
  case LsCmdOpts -> LsCmds
lsView LsCmdOpts
lsOpts of
    LsSnapshot SnapshotOpts {Bool
LsView
soptNightlySnapView :: Bool
soptLtsSnapView :: Bool
soptViewType :: LsView
soptNightlySnapView :: SnapshotOpts -> Bool
soptLtsSnapView :: SnapshotOpts -> Bool
soptViewType :: SnapshotOpts -> LsView
..} ->
      case LsView
soptViewType of
        LsView
Local -> LsCmdOpts -> RIO Runner ()
handleLocal LsCmdOpts
lsOpts
        LsView
Remote -> forall env. HasRunner env => LsCmdOpts -> RIO env ()
handleRemote LsCmdOpts
lsOpts
    LsDependencies ListDepsOpts
depOpts -> ListDepsOpts -> RIO Runner ()
listDependencies ListDepsOpts
depOpts
    LsStyles ListStylesOpts
stylesOpts -> forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall a b. (a -> b) -> a -> b
$ ListStylesOpts -> RIO Config ()
listStylesCmd ListStylesOpts
stylesOpts
    LsTools ListToolsOpts
toolsOpts -> forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall a b. (a -> b) -> a -> b
$ ListToolsOpts -> RIO Config ()
listToolsCmd ListToolsOpts
toolsOpts

-- | List Stack's output styles

listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd ListStylesOpts
opts = do
  Config
lc <- forall r (m :: * -> *). MonadReader r m => m r
ask
  -- This is the same test as is used in Stack.Types.Runner.withRunner

  let useColor :: Bool
useColor = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasTerm env => Lens' env Bool
useColorL Config
lc
      styles :: [StyleSpec]
styles = forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
defaultStyles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// StylesUpdate -> [(Style, StyleSpec)]
stylesUpdate (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL Config
lc)
      isComplex :: Bool
isComplex = Bool -> Bool
not (ListStylesOpts -> Bool
coptBasic ListStylesOpts
opts)
      showSGR :: Bool
showSGR = Bool
isComplex Bool -> Bool -> Bool
&& ListStylesOpts -> Bool
coptSGR ListStylesOpts
opts
      showExample :: Bool
showExample = Bool
isComplex Bool -> Bool -> Bool
&& ListStylesOpts -> Bool
coptExample ListStylesOpts
opts Bool -> Bool -> Bool
&& Bool
useColor
      styleReports :: [Text]
styleReports = forall a b. (a -> b) -> [a] -> [b]
L.map (Bool -> Bool -> StyleSpec -> Text
styleReport Bool
showSGR Bool
showExample) [StyleSpec]
styles
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate (if Bool
isComplex then Text
"\n" else Text
":") [Text]
styleReports
 where
  styleReport :: Bool -> Bool -> StyleSpec -> Text
  styleReport :: Bool -> Bool -> StyleSpec -> Text
styleReport Bool
showSGR Bool
showExample (Text
k, [SGR]
sgrs) = Text
k forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
codes
    forall a. Semigroup a => a -> a -> a
<> (if Bool
showSGR then Text
sgrsList else forall a. Monoid a => a
mempty)
    forall a. Semigroup a => a -> a -> a
<> (if Bool
showExample then Text
example else forall a. Monoid a => a
mempty)
   where
    codes :: Text
codes = Text -> [Text] -> Text
T.intercalate Text
";" (forall a b. (a -> b) -> [a] -> [b]
L.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a b. (a -> b) -> a -> b
$
              forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap SGR -> [Int]
sgrToCode [SGR]
sgrs)
    sgrsList :: Text
sgrsList = Text
" [" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
L.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) [SGR]
sgrs)
               forall a. Semigroup a => a -> a -> a
<> Text
"]"
    example :: Text
example = Text
" " forall a. Semigroup a => a -> a -> a
<> Text
ansi forall a. Semigroup a => a -> a -> a
<> Text
"Example" forall a. Semigroup a => a -> a -> a
<> Text
reset
    ansi :: Text
ansi = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> [Char]
setSGRCode [SGR]
sgrs
    reset :: Text
reset = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> [Char]
setSGRCode [SGR
Reset]

-- | List Stack's installed tools, sorted (see instance of 'Ord' for 'Tool').

listToolsCmd :: ListToolsOpts -> RIO Config ()
listToolsCmd :: ListToolsOpts -> RIO Config ()
listToolsCmd ListToolsOpts
opts = do
  Path Abs Dir
localPrograms <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalPrograms
  [Tool]
installed <- forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> m [Tool]
listInstalled Path Abs Dir
localPrograms
  let wanted :: [Tool]
wanted = case ListToolsOpts -> [Char]
toptFilter ListToolsOpts
opts of
        [] -> [Tool]
installed
        [Char]
"ghc-git" -> [Tool
t | t :: Tool
t@(ToolGhcGit Text
_ Text
_) <- [Tool]
installed]
        [Char]
pkgName -> [Char] -> [Tool] -> [Tool]
filtered [Char]
pkgName [Tool]
installed
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tool -> [Char]
toolString) [Tool]
wanted
 where
  filtered :: [Char] -> [Tool] -> [Tool]
filtered [Char]
pkgName [Tool]
installed = PackageIdentifier -> Tool
Tool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      PackageName -> (Version -> Bool) -> [Tool] -> [PackageIdentifier]
filterTools ([Char] -> PackageName
mkPackageName [Char]
pkgName) (forall a b. a -> b -> a
const Bool
True) [Tool]
installed