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

module Stack.Ls
  ( lsCmd
  , lsParser
  ) where

import           Data.Aeson
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
                   ( httpJSON, addRequestHeader, getResponseBody, parseRequest
                   , hAccept
                   )
import qualified Options.Applicative as OA
import           Options.Applicative ( idm )
import           Options.Applicative.Builder.Extra ( boolFlags )
import           Path
import           RIO.List ( sort )
import           Stack.Constants ( osIsWindows, globalFooter )
import           Stack.Dot
import           Stack.Prelude hiding ( Snapshot (..), SnapName (..) )
import           Stack.Runners
import           Stack.Options.DotParser ( listDepsOptsParser )
import           Stack.Setup.Installed
                   ( Tool (..), filterTools, listInstalled, toolString )
import           Stack.Types.Config
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 -> String
(Int -> LsException -> ShowS)
-> (LsException -> String)
-> ([LsException] -> ShowS)
-> Show LsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LsException -> ShowS
showsPrec :: Int -> LsException -> ShowS
$cshow :: LsException -> String
show :: LsException -> String
$cshowList :: [LsException] -> ShowS
showList :: [LsException] -> ShowS
Show, Typeable)

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

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

data SnapshotType
    = Lts
    | Nightly
    deriving (Int -> SnapshotType -> ShowS
[SnapshotType] -> ShowS
SnapshotType -> String
(Int -> SnapshotType -> ShowS)
-> (SnapshotType -> String)
-> ([SnapshotType] -> ShowS)
-> Show SnapshotType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotType -> ShowS
showsPrec :: Int -> SnapshotType -> ShowS
$cshow :: SnapshotType -> String
show :: SnapshotType -> String
$cshowList :: [SnapshotType] -> ShowS
showList :: [SnapshotType] -> ShowS
Show, SnapshotType -> SnapshotType -> Bool
(SnapshotType -> SnapshotType -> Bool)
-> (SnapshotType -> SnapshotType -> Bool) -> Eq SnapshotType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotType -> SnapshotType -> Bool
== :: SnapshotType -> SnapshotType -> Bool
$c/= :: SnapshotType -> SnapshotType -> Bool
/= :: SnapshotType -> SnapshotType -> Bool
Eq, Eq SnapshotType
Eq SnapshotType
-> (SnapshotType -> SnapshotType -> Ordering)
-> (SnapshotType -> SnapshotType -> Bool)
-> (SnapshotType -> SnapshotType -> Bool)
-> (SnapshotType -> SnapshotType -> Bool)
-> (SnapshotType -> SnapshotType -> Bool)
-> (SnapshotType -> SnapshotType -> SnapshotType)
-> (SnapshotType -> SnapshotType -> SnapshotType)
-> Ord 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
$ccompare :: SnapshotType -> SnapshotType -> Ordering
compare :: SnapshotType -> SnapshotType -> Ordering
$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
>= :: SnapshotType -> SnapshotType -> Bool
$cmax :: SnapshotType -> SnapshotType -> SnapshotType
max :: SnapshotType -> SnapshotType -> SnapshotType
$cmin :: SnapshotType -> SnapshotType -> SnapshotType
min :: SnapshotType -> SnapshotType -> SnapshotType
Ord)

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

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

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

newtype ListToolsOpts = ListToolsOpts
    { ListToolsOpts -> String
toptFilter  :: String
    }

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

lsParser :: OA.Parser LsCmdOpts
lsParser :: Parser LsCmdOpts
lsParser = LsCmds -> LsCmdOpts
LsCmdOpts
    (LsCmds -> LsCmdOpts) -> Parser LsCmds -> Parser LsCmdOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod CommandFields LsCmds -> Parser LsCmds
forall a. Mod CommandFields a -> Parser a
OA.hsubparser (Mod CommandFields LsCmds
lsSnapCmd Mod CommandFields LsCmds
-> Mod CommandFields LsCmds -> Mod CommandFields LsCmds
forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsCmds
lsDepsCmd Mod CommandFields LsCmds
-> Mod CommandFields LsCmds -> Mod CommandFields LsCmds
forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsCmds
lsStylesCmd Mod CommandFields LsCmds
-> Mod CommandFields LsCmds -> Mod CommandFields LsCmds
forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsCmds
lsToolsCmd)

lsCmdOptsParser :: OA.Parser LsCmds
lsCmdOptsParser :: Parser LsCmds
lsCmdOptsParser = SnapshotOpts -> LsCmds
LsSnapshot (SnapshotOpts -> LsCmds) -> Parser SnapshotOpts -> Parser LsCmds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SnapshotOpts
lsViewSnapCmd

lsDepOptsParser :: OA.Parser LsCmds
lsDepOptsParser :: Parser LsCmds
lsDepOptsParser = ListDepsOpts -> LsCmds
LsDependencies (ListDepsOpts -> LsCmds) -> Parser ListDepsOpts -> Parser LsCmds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ListDepsOpts
listDepsOptsParser

lsStylesOptsParser :: OA.Parser LsCmds
lsStylesOptsParser :: Parser LsCmds
lsStylesOptsParser = ListStylesOpts -> LsCmds
LsStyles (ListStylesOpts -> LsCmds)
-> Parser ListStylesOpts -> Parser LsCmds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ListStylesOpts
listStylesOptsParser

lsToolsOptsParser :: OA.Parser LsCmds
lsToolsOptsParser :: Parser LsCmds
lsToolsOptsParser = ListToolsOpts -> LsCmds
LsTools (ListToolsOpts -> LsCmds) -> Parser ListToolsOpts -> Parser LsCmds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ListToolsOpts
listToolsOptsParser

listStylesOptsParser :: OA.Parser ListStylesOpts
listStylesOptsParser :: Parser ListStylesOpts
listStylesOptsParser = Bool -> Bool -> Bool -> ListStylesOpts
ListStylesOpts
    (Bool -> Bool -> Bool -> ListStylesOpts)
-> Parser Bool -> Parser (Bool -> Bool -> ListStylesOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
False
                  String
"basic"
                  String
"a basic report of the styles used. The default is a fuller \
                  \one"
                  Mod FlagFields Bool
forall m. Monoid m => m
idm
    Parser (Bool -> Bool -> ListStylesOpts)
-> Parser Bool -> Parser (Bool -> ListStylesOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True
                  String
"sgr"
                  String
"the provision of the equivalent SGR instructions (provided \
                  \by default). Flag ignored for a basic report"
                  Mod FlagFields Bool
forall m. Monoid m => m
idm
    Parser (Bool -> ListStylesOpts)
-> Parser Bool -> Parser ListStylesOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True
                  String
"example"
                  String
"the provision of an example of the applied style (provided \
                  \by default for colored output). Flag ignored for a basic \
                  \report"
                  Mod FlagFields Bool
forall m. Monoid m => m
idm

listToolsOptsParser :: OA.Parser ListToolsOpts
listToolsOptsParser :: Parser ListToolsOpts
listToolsOptsParser = String -> ListToolsOpts
ListToolsOpts
    (String -> ListToolsOpts) -> Parser String -> Parser ListToolsOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
OA.strOption
            ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"filter"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"TOOL_NAME"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
OA.value String
""
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
OA.help String
"Filter by a tool name (eg 'ghc', 'ghc-git' or 'msys2') \
                      \- case sensitive. The default is no filter"
            )

lsViewSnapCmd :: OA.Parser SnapshotOpts
lsViewSnapCmd :: Parser SnapshotOpts
lsViewSnapCmd =
    LsView -> Bool -> Bool -> SnapshotOpts
SnapshotOpts (LsView -> Bool -> Bool -> SnapshotOpts)
-> Parser LsView -> Parser (Bool -> Bool -> SnapshotOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Mod CommandFields LsView -> Parser LsView
forall a. Mod CommandFields a -> Parser a
OA.hsubparser (Mod CommandFields LsView
lsViewRemoteCmd Mod CommandFields LsView
-> Mod CommandFields LsView -> Mod CommandFields LsView
forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsView
lsViewLocalCmd) Parser LsView -> Parser LsView -> Parser LsView
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LsView -> Parser LsView
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LsView
Local) Parser (Bool -> Bool -> SnapshotOpts)
-> Parser Bool -> Parser (Bool -> SnapshotOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Mod FlagFields Bool -> Parser Bool
OA.switch
        (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"lts" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short Char
'l' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
OA.help String
"Only show lts snapshots") Parser (Bool -> SnapshotOpts) -> Parser Bool -> Parser SnapshotOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Mod FlagFields Bool -> Parser Bool
OA.switch
        (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"nightly" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short Char
'n' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<>
         String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
OA.help String
"Only show nightly snapshots")

lsSnapCmd :: OA.Mod OA.CommandFields LsCmds
lsSnapCmd :: Mod CommandFields LsCmds
lsSnapCmd = String -> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"snapshots" (ParserInfo LsCmds -> Mod CommandFields LsCmds)
-> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a b. (a -> b) -> a -> b
$
  Parser LsCmds -> InfoMod LsCmds -> ParserInfo LsCmds
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsCmdOptsParser (InfoMod LsCmds -> ParserInfo LsCmds)
-> InfoMod LsCmds -> ParserInfo LsCmds
forall a b. (a -> b) -> a -> b
$
       String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.progDesc String
"View snapshots (local by default)"
    InfoMod LsCmds -> InfoMod LsCmds -> InfoMod LsCmds
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.footer String
localSnapshotMsg

lsDepsCmd :: OA.Mod OA.CommandFields LsCmds
lsDepsCmd :: Mod CommandFields LsCmds
lsDepsCmd = String -> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"dependencies" (ParserInfo LsCmds -> Mod CommandFields LsCmds)
-> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a b. (a -> b) -> a -> b
$
    Parser LsCmds -> InfoMod LsCmds -> ParserInfo LsCmds
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsDepOptsParser (InfoMod LsCmds -> ParserInfo LsCmds)
-> InfoMod LsCmds -> ParserInfo LsCmds
forall a b. (a -> b) -> a -> b
$
         String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.progDesc String
"View the dependencies"
      InfoMod LsCmds -> InfoMod LsCmds -> InfoMod LsCmds
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.footer String
globalFooter

lsStylesCmd :: OA.Mod OA.CommandFields LsCmds
lsStylesCmd :: Mod CommandFields LsCmds
lsStylesCmd =
    String -> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
        String
"stack-colors"
        (Parser LsCmds -> InfoMod LsCmds -> ParserInfo LsCmds
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsStylesOptsParser
                 (String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.progDesc String
"View Stack's output styles"))
    Mod CommandFields LsCmds
-> Mod CommandFields LsCmds -> Mod CommandFields LsCmds
forall a. Semigroup a => a -> a -> a
<>
    String -> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
        String
"stack-colours"
        (Parser LsCmds -> InfoMod LsCmds -> ParserInfo LsCmds
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsStylesOptsParser
                 (String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.progDesc String
"View Stack's output styles (alias for \
                              \'stack-colors')"))

lsToolsCmd :: OA.Mod OA.CommandFields LsCmds
lsToolsCmd :: Mod CommandFields LsCmds
lsToolsCmd =
    String -> ParserInfo LsCmds -> Mod CommandFields LsCmds
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
        String
"tools"
        (Parser LsCmds -> InfoMod LsCmds -> ParserInfo LsCmds
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsToolsOptsParser (String -> InfoMod LsCmds
forall a. String -> InfoMod a
OA.progDesc String
"View Stack's installed tools"))

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

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

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

instance FromJSON SnapshotData where
    parseJSON :: Value -> Parser SnapshotData
parseJSON (Object Object
s) =
        Integer -> [[Snapshot]] -> SnapshotData
SnapshotData (Integer -> [[Snapshot]] -> SnapshotData)
-> Parser Integer -> Parser ([[Snapshot]] -> SnapshotData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
s Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"totalCount" Parser ([[Snapshot]] -> SnapshotData)
-> Parser [[Snapshot]] -> Parser SnapshotData
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
s Object -> Key -> Parser [[Snapshot]]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"snapshots"
    parseJSON Value
_ = Parser SnapshotData
forall m. Monoid m => m
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 = LsException -> Snapshot
forall e a. Exception e => e -> a
impureThrow (LsException -> Snapshot) -> LsException -> Snapshot
forall a b. (a -> b) -> a -> b
$ [Value] -> LsException
ParseFailure [Value]
val

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

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

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

displaySingleSnap :: [Snapshot] -> Text
displaySingleSnap :: [Snapshot] -> Text
displaySingleSnap [Snapshot]
snapshots =
    case [Snapshot]
snapshots of
        [] -> Text
forall m. Monoid m => m
mempty
        (Snapshot
x:[Snapshot]
xs) ->
            let snaps :: [Text]
snaps =
                    Snapshot -> [Text]
displayTime Snapshot
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"\n\n"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Snapshot -> [Text]
displaySnap Snapshot
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>
                    (Snapshot -> [Text]) -> [Snapshot] -> [Text]
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 [[Snapshot]] -> [[Snapshot]]
forall a. [a] -> [a]
L.reverse ([[Snapshot]] -> [[Snapshot]]) -> [[Snapshot]] -> [[Snapshot]]
forall a b. (a -> b) -> a -> b
$ SnapshotData -> [[Snapshot]]
snaps SnapshotData
sdata of
        [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [[Snapshot]]
xs ->
            let snaps :: Text
snaps = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Snapshot] -> Text) -> [[Snapshot]] -> [Text]
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 -> ([Snapshot] -> [Snapshot]) -> [[Snapshot]] -> [[Snapshot]]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Snapshot -> Bool) -> [Snapshot] -> [Snapshot]
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 ->
                ([Snapshot] -> [Snapshot]) -> [[Snapshot]] -> [[Snapshot]]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Snapshot -> Bool) -> [Snapshot] -> [Snapshot]
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 -> [String] -> IO ()
displayLocalSnapshot Bool
term [String]
xs = Bool -> Text -> IO ()
renderData Bool
term ([String] -> Text
localSnaptoText [String]
xs)

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

handleLocal :: LsCmdOpts -> RIO Runner ()
handleLocal :: LsCmdOpts -> RIO Runner ()
handleLocal LsCmdOpts
lsOpts = do
    (Path Abs Dir
instRoot :: Path Abs Dir) <- ShouldReexec
-> RIO Config (Path Abs Dir) -> RIO Runner (Path Abs Dir)
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config (Path Abs Dir) -> RIO Runner (Path Abs Dir))
-> RIO Config (Path Abs Dir) -> RIO Runner (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ RIO EnvConfig (Path Abs Dir) -> RIO Config (Path Abs Dir)
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig RIO EnvConfig (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
    Bool
isStdoutTerminal <- Getting Bool Runner Bool -> RIO Runner Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Runner Bool
forall env. HasRunner env => Lens' env Bool
Lens' Runner Bool
terminalL
    let parentInstRoot :: Path Abs Dir
parentInstRoot = Path Abs Dir -> Path Abs Dir
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   = Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
parentInstRoot
    [String]
snapData' <- IO [String] -> RIO Runner [String]
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> RIO Runner [String])
-> IO [String] -> RIO Runner [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
snapRootDir
    let snapData :: [String]
snapData = [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort [String]
snapData'
    case LsCmdOpts -> LsCmds
lsView LsCmdOpts
lsOpts of
        LsSnapshot SnapshotOpts {Bool
LsView
soptViewType :: SnapshotOpts -> LsView
soptLtsSnapView :: SnapshotOpts -> Bool
soptNightlySnapView :: SnapshotOpts -> Bool
soptViewType :: LsView
soptLtsSnapView :: Bool
soptNightlySnapView :: Bool
..} ->
            case (Bool
soptLtsSnapView, Bool
soptNightlySnapView) of
                (Bool
True, Bool
False) ->
                    IO () -> RIO Runner ()
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Runner ()) -> IO () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
                    Bool -> [String] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"lts") [String]
snapData
                (Bool
False, Bool
True) ->
                    IO () -> RIO Runner ()
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Runner ()) -> IO () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
                    Bool -> [String] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"night") [String]
snapData
                (Bool, Bool)
_ -> IO () -> RIO Runner ()
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Runner ()) -> IO () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal [String]
snapData
        LsDependencies ListDepsOpts
_ -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LsStyles ListStylesOpts
_ -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LsTools ListToolsOpts
_ -> () -> RIO Runner ()
forall a. a -> RIO Runner a
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 <- IO Request -> RIO env Request
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> RIO env Request) -> IO Request -> RIO env Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
urlInfo
    Bool
isStdoutTerminal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasRunner env => Lens' env Bool
Lens' env Bool
terminalL
    let req' :: Request
req' = HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAccept ByteString
"application/json" Request
req
    Response SnapshotData
result <- Request -> RIO env (Response SnapshotData)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON Request
req'
    let snapData :: SnapshotData
snapData = Response SnapshotData -> SnapshotData
forall a. Response a -> a
getResponseBody Response SnapshotData
result
    case LsCmdOpts -> LsCmds
lsView LsCmdOpts
lsOpts of
        LsSnapshot SnapshotOpts {Bool
LsView
soptViewType :: SnapshotOpts -> LsView
soptLtsSnapView :: SnapshotOpts -> Bool
soptNightlySnapView :: SnapshotOpts -> Bool
soptViewType :: LsView
soptLtsSnapView :: Bool
soptNightlySnapView :: Bool
..} ->
            case (Bool
soptLtsSnapView, Bool
soptNightlySnapView) of
                (Bool
True, Bool
False) ->
                    IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
isStdoutTerminal (SnapshotData -> IO ()) -> SnapshotData -> IO ()
forall a b. (a -> b) -> a -> b
$
                    SnapshotData -> SnapshotType -> SnapshotData
filterSnapshotData SnapshotData
snapData SnapshotType
Lts
                (Bool
False, Bool
True) ->
                    IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
isStdoutTerminal (SnapshotData -> IO ()) -> SnapshotData -> IO ()
forall a b. (a -> b) -> a -> b
$
                    SnapshotData -> SnapshotType -> SnapshotData
filterSnapshotData SnapshotData
snapData SnapshotType
Nightly
                (Bool, Bool)
_ -> IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Bool -> SnapshotData -> IO ()
displaySnapshotData Bool
isStdoutTerminal SnapshotData
snapData
        LsDependencies ListDepsOpts
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LsStyles ListStylesOpts
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LsTools ListToolsOpts
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    urlInfo :: String
urlInfo = String
"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
soptViewType :: SnapshotOpts -> LsView
soptLtsSnapView :: SnapshotOpts -> Bool
soptNightlySnapView :: SnapshotOpts -> Bool
soptViewType :: LsView
soptLtsSnapView :: Bool
soptNightlySnapView :: Bool
..} ->
            case LsView
soptViewType of
                LsView
Local -> LsCmdOpts -> RIO Runner ()
handleLocal LsCmdOpts
lsOpts
                LsView
Remote -> LsCmdOpts -> RIO Runner ()
forall env. HasRunner env => LsCmdOpts -> RIO env ()
handleRemote LsCmdOpts
lsOpts
        LsDependencies ListDepsOpts
depOpts -> ListDepsOpts -> RIO Runner ()
listDependencies ListDepsOpts
depOpts
        LsStyles ListStylesOpts
stylesOpts -> 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
$ ListStylesOpts -> RIO Config ()
listStylesCmd ListStylesOpts
stylesOpts
        LsTools ListToolsOpts
toolsOpts -> 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
$ ListToolsOpts -> RIO Config ()
listToolsCmd ListToolsOpts
toolsOpts

lsViewLocalCmd :: OA.Mod OA.CommandFields LsView
lsViewLocalCmd :: Mod CommandFields LsView
lsViewLocalCmd = String -> ParserInfo LsView -> Mod CommandFields LsView
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"local" (ParserInfo LsView -> Mod CommandFields LsView)
-> ParserInfo LsView -> Mod CommandFields LsView
forall a b. (a -> b) -> a -> b
$
  Parser LsView -> InfoMod LsView -> ParserInfo LsView
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (LsView -> Parser LsView
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LsView
Local) (InfoMod LsView -> ParserInfo LsView)
-> InfoMod LsView -> ParserInfo LsView
forall a b. (a -> b) -> a -> b
$
       String -> InfoMod LsView
forall a. String -> InfoMod a
OA.progDesc String
"View local snapshots"
    InfoMod LsView -> InfoMod LsView -> InfoMod LsView
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod LsView
forall a. String -> InfoMod a
OA.footer String
localSnapshotMsg

lsViewRemoteCmd :: OA.Mod OA.CommandFields LsView
lsViewRemoteCmd :: Mod CommandFields LsView
lsViewRemoteCmd = String -> ParserInfo LsView -> Mod CommandFields LsView
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"remote" (ParserInfo LsView -> Mod CommandFields LsView)
-> ParserInfo LsView -> Mod CommandFields LsView
forall a b. (a -> b) -> a -> b
$
  Parser LsView -> InfoMod LsView -> ParserInfo LsView
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (LsView -> Parser LsView
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LsView
Remote) (InfoMod LsView -> ParserInfo LsView)
-> InfoMod LsView -> ParserInfo LsView
forall a b. (a -> b) -> a -> b
$
       String -> InfoMod LsView
forall a. String -> InfoMod a
OA.progDesc String
"View remote snapshots"
    InfoMod LsView -> InfoMod LsView -> InfoMod LsView
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod LsView
forall a. String -> InfoMod a
OA.footer String
pagerMsg

pagerMsg :: String
pagerMsg :: String
pagerMsg =
  String
"On a terminal, uses a pager, if one is available. Respects the PAGER \
  \environment variable (subject to that, prefers pager 'less' to 'more')."

localSnapshotMsg :: String
localSnapshotMsg :: String
localSnapshotMsg =
  String
"A local snapshot is identified by a hash code. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
pagerMsg

-- | List Stack's output styles

listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd ListStylesOpts
opts = do
    Config
lc <- RIO Config Config
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 = Getting Bool Config Bool -> Config -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool Config Bool
forall env. HasTerm env => Lens' env Bool
Lens' Config Bool
useColorL Config
lc
        styles :: [StyleSpec]
styles = Array Style StyleSpec -> [StyleSpec]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems (Array Style StyleSpec -> [StyleSpec])
-> Array Style StyleSpec -> [StyleSpec]
forall a b. (a -> b) -> a -> b
$ Array Style StyleSpec
defaultStyles Array Style StyleSpec
-> [(Style, StyleSpec)] -> Array Style StyleSpec
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// StylesUpdate -> [(Style, StyleSpec)]
stylesUpdate (Getting StylesUpdate Config StylesUpdate -> Config -> StylesUpdate
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting StylesUpdate Config StylesUpdate
forall env. HasStylesUpdate env => Lens' env StylesUpdate
Lens' Config 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 = (StyleSpec -> Text) -> [StyleSpec] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map (Bool -> Bool -> StyleSpec -> Text
styleReport Bool
showSGR Bool
showExample) [StyleSpec]
styles
    IO () -> RIO Config ()
forall a. IO a -> RIO Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Config ()) -> IO () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
codes
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
showSGR then Text
sgrsList else Text
forall m. Monoid m => m
mempty)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
showExample then Text
example else Text
forall m. Monoid m => m
mempty)
      where
        codes :: Text
codes = Text -> [Text] -> Text
T.intercalate Text
";" ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) ([Int] -> [Text]) -> [Int] -> [Text]
forall a b. (a -> b) -> a -> b
$
                    (SGR -> [Int]) -> [SGR] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap SGR -> [Int]
sgrToCode [SGR]
sgrs)
        sgrsList :: Text
sgrsList = Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((SGR -> Text) -> [SGR] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (SGR -> String) -> SGR -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SGR -> String
forall a. Show a => a -> String
show) [SGR]
sgrs)
                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
        example :: Text
example = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ansi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Example" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reset
        ansi :: Text
ansi = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR]
sgrs
        reset :: Text
reset = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
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 <- Getting (Path Abs Dir) Config (Path Abs Dir)
-> RIO Config (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) Config (Path Abs Dir)
 -> RIO Config (Path Abs Dir))
-> Getting (Path Abs Dir) Config (Path Abs Dir)
-> RIO Config (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> Config -> Const (Path Abs Dir) Config
forall env. HasConfig env => Lens' env Config
Lens' Config Config
configL((Config -> Const (Path Abs Dir) Config)
 -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) Config (Path Abs Dir)
-> Getting (Path Abs Dir) Config (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalPrograms
    [Tool]
installed <- [Tool] -> [Tool]
forall a. Ord a => [a] -> [a]
sort ([Tool] -> [Tool]) -> RIO Config [Tool] -> RIO Config [Tool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> RIO Config [Tool]
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> m [Tool]
listInstalled Path Abs Dir
localPrograms
    let wanted :: [Tool]
wanted = case ListToolsOpts -> String
toptFilter ListToolsOpts
opts of
            [] -> [Tool]
installed
            String
"ghc-git" -> [Tool
t | t :: Tool
t@(ToolGhcGit Text
_ Text
_) <- [Tool]
installed]
            String
pkgName -> String -> [Tool] -> [Tool]
filtered String
pkgName [Tool]
installed
    IO () -> RIO Config ()
forall a. IO a -> RIO Config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Config ()) -> IO () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ (Tool -> IO ()) -> [Tool] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Tool -> String) -> Tool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tool -> String
toolString) [Tool]
wanted
  where
    filtered :: String -> [Tool] -> [Tool]
filtered String
pkgName [Tool]
installed = PackageIdentifier -> Tool
Tool (PackageIdentifier -> Tool) -> [PackageIdentifier] -> [Tool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        PackageName -> (Version -> Bool) -> [Tool] -> [PackageIdentifier]
filterTools (String -> PackageName
mkPackageName String
pkgName) (Bool -> Version -> Bool
forall a b. a -> b -> a
const Bool
True) [Tool]
installed