{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Ls
( lsCmd
, lsParser
) where
import Control.Exception (throw)
import Data.Aeson
import Data.Array.IArray ((//), elems)
import Distribution.Package (mkPackageName)
import Stack.Prelude hiding (Snapshot (..), SnapName (..))
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 RIO.PrettyPrint (useColorL)
import RIO.PrettyPrint.DefaultStyles (defaultStyles)
import RIO.PrettyPrint.Types (StyleSpec)
import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), stylesUpdateL)
import Stack.Constants (osIsWindows)
import Stack.Dot
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)
data LsView
= Local
| Remote
deriving (Int -> LsView -> ShowS
[LsView] -> ShowS
LsView -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LsView] -> ShowS
$cshowList :: [LsView] -> ShowS
show :: LsView -> String
$cshow :: LsView -> String
showsPrec :: Int -> LsView -> ShowS
$cshowsPrec :: Int -> LsView -> ShowS
Show, 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)
data SnapshotType
= Lts
| Nightly
deriving (Int -> SnapshotType -> ShowS
[SnapshotType] -> ShowS
SnapshotType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotType] -> ShowS
$cshowList :: [SnapshotType] -> ShowS
show :: SnapshotType -> String
$cshow :: SnapshotType -> String
showsPrec :: Int -> SnapshotType -> ShowS
$cshowsPrec :: Int -> SnapshotType -> ShowS
Show, 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)
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
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, Int -> SnapshotOpts -> ShowS
[SnapshotOpts] -> ShowS
SnapshotOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotOpts] -> ShowS
$cshowList :: [SnapshotOpts] -> ShowS
show :: SnapshotOpts -> String
$cshow :: SnapshotOpts -> String
showsPrec :: Int -> SnapshotOpts -> ShowS
$cshowsPrec :: Int -> SnapshotOpts -> ShowS
Show, 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)
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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ListStylesOpts] -> ShowS
$cshowList :: [ListStylesOpts] -> ShowS
show :: ListStylesOpts -> String
$cshow :: ListStylesOpts -> String
showsPrec :: Int -> ListStylesOpts -> ShowS
$cshowsPrec :: Int -> 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
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Mod CommandFields a -> Parser a
OA.hsubparser (Mod CommandFields LsCmds
lsSnapCmd forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsCmds
lsDepsCmd forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsCmds
lsStylesCmd forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsCmds
lsToolsCmd)
lsCmdOptsParser :: OA.Parser LsCmds
lsCmdOptsParser :: Parser LsCmds
lsCmdOptsParser = SnapshotOpts -> LsCmds
LsSnapshot 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 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 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 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
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"
forall m. Monoid m => m
idm
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"
forall m. Monoid m => m
idm
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"
forall m. Monoid m => m
idm
listToolsOptsParser :: OA.Parser ListToolsOpts
listToolsOptsParser :: Parser ListToolsOpts
listToolsOptsParser = String -> ListToolsOpts
ListToolsOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
OA.strOption
( forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"filter"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OA.metavar String
"TOOL_NAME"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
OA.value String
""
forall a. Semigroup a => a -> a -> a
<> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(forall a. Mod CommandFields a -> Parser a
OA.hsubparser (Mod CommandFields LsView
lsViewRemoteCmd forall a. Semigroup a => a -> a -> a
<> Mod CommandFields LsView
lsViewLocalCmd) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure LsView
Local) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Mod FlagFields Bool -> Parser Bool
OA.switch
(forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"lts" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short Char
'l' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
OA.help String
"Only show lts snapshots") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Mod FlagFields Bool -> Parser Bool
OA.switch
(forall (f :: * -> *) a. HasName f => String -> Mod f a
OA.long String
"nightly" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
OA.short Char
'n' forall a. Semigroup a => a -> a -> a
<>
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 = forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"snapshots" forall a b. (a -> b) -> a -> b
$
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsCmdOptsParser forall a b. (a -> b) -> a -> b
$
forall a. String -> InfoMod a
OA.progDesc String
"View snapshots (local by default)"
forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
OA.footer String
localSnapshotMsg
lsDepsCmd :: OA.Mod OA.CommandFields LsCmds
lsDepsCmd :: Mod CommandFields LsCmds
lsDepsCmd =
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
String
"dependencies"
(forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsDepOptsParser (forall a. String -> InfoMod a
OA.progDesc String
"View the dependencies"))
lsStylesCmd :: OA.Mod OA.CommandFields LsCmds
lsStylesCmd :: Mod CommandFields LsCmds
lsStylesCmd =
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
String
"stack-colors"
(forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsStylesOptsParser
(forall a. String -> InfoMod a
OA.progDesc String
"View stack's output styles"))
forall a. Semigroup a => a -> a -> a
<>
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
String
"stack-colours"
(forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsStylesOptsParser
(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 =
forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command
String
"tools"
(forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info Parser LsCmds
lsToolsOptsParser (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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Snapshot] -> ShowS
$cshowList :: [Snapshot] -> ShowS
show :: Snapshot -> String
$cshow :: Snapshot -> String
showsPrec :: Int -> Snapshot -> ShowS
$cshowsPrec :: Int -> Snapshot -> ShowS
Show, 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)
data SnapshotData = SnapshotData
{ SnapshotData -> Integer
_snapTotalCounts :: Integer
, SnapshotData -> [[Snapshot]]
snaps :: [[Snapshot]]
} deriving (Int -> SnapshotData -> ShowS
[SnapshotData] -> ShowS
SnapshotData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotData] -> ShowS
$cshowList :: [SnapshotData] -> ShowS
show :: SnapshotData -> String
$cshow :: SnapshotData -> String
showsPrec :: Int -> SnapshotData -> ShowS
$cshowsPrec :: Int -> SnapshotData -> ShowS
Show, 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)
instance FromJSON Snapshot where
parseJSON :: Value -> Parser Snapshot
parseJSON o :: Value
o@(Array Array
_) = Value -> Parser Snapshot
parseSnapshot Value
o
parseJSON Value
_ = forall m. Monoid m => m
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 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 = forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ [Value] -> LsException
ParseFailure [Value]
val
newtype LsException =
ParseFailure [Value]
deriving (Int -> LsException -> ShowS
[LsException] -> ShowS
LsException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LsException] -> ShowS
$cshowList :: [LsException] -> ShowS
show :: LsException -> String
$cshow :: LsException -> String
showsPrec :: Int -> LsException -> ShowS
$cshowsPrec :: Int -> LsException -> ShowS
Show, Typeable)
instance Exception LsException
parseSnapshot :: Value -> A.Parser Snapshot
parseSnapshot :: Value -> Parser Snapshot
parseSnapshot = forall a. String -> (Array -> Parser a) -> Value -> Parser a
A.withArray String
"array of snapshot" (forall (m :: * -> *) a. Monad m => a -> m a
return 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 m. Monoid m => m
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 (m :: * -> *) a. Monad m => a -> m a
return ()
[[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 -> [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" forall a b. (a -> b) -> a -> b
$ 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) <- 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
[String]
snapData' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs Dir
snapRootDir
let snapData :: [String]
snapData = forall a. Ord a => [a] -> [a]
L.sort [String]
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 -> [String] -> 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 String
"lts") [String]
snapData
(Bool
False, Bool
True) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Bool -> [String] -> 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 String
"night") [String]
snapData
(Bool, Bool)
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal [String]
snapData
LsDependencies ListDepsOpts
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
LsStyles ListStylesOpts
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
LsTools ListToolsOpts
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 => String -> m Request
parseRequest String
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 (m :: * -> *) a. Monad m => a -> m a
return ()
LsStyles ListStylesOpts
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
LsTools ListToolsOpts
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
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
lsViewLocalCmd :: OA.Mod OA.CommandFields LsView
lsViewLocalCmd :: Mod CommandFields LsView
lsViewLocalCmd = forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"local" forall a b. (a -> b) -> a -> b
$
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (forall (f :: * -> *) a. Applicative f => a -> f a
pure LsView
Local) forall a b. (a -> b) -> a -> b
$
forall a. String -> InfoMod a
OA.progDesc String
"View local snapshots"
forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
OA.footer String
localSnapshotMsg
lsViewRemoteCmd :: OA.Mod OA.CommandFields LsView
lsViewRemoteCmd :: Mod CommandFields LsView
lsViewRemoteCmd = forall a. String -> ParserInfo a -> Mod CommandFields a
OA.command String
"remote" forall a b. (a -> b) -> a -> b
$
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (forall (f :: * -> *) a. Applicative f => a -> f a
pure LsView
Remote) forall a b. (a -> b) -> a -> b
$
forall a. String -> InfoMod a
OA.progDesc String
"View remote snapshots"
forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
OA.footer String
pagerMsg
pagerMsg :: String
=
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. " forall a. Semigroup a => a -> a -> a
<> String
pagerMsg
listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd :: ListStylesOpts -> RIO Config ()
listStylesCmd ListStylesOpts
opts = do
Config
lc <- forall r (m :: * -> *). MonadReader r m => m r
ask
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 m. Monoid m => m
mempty)
forall a. Semigroup a => a -> a -> a
<> (if Bool
showExample then Text
example else forall m. Monoid m => m
mempty)
where
codes :: Text
codes = Text -> [Text] -> Text
T.intercalate Text
";" (forall a b. (a -> b) -> [a] -> [b]
L.map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
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 => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
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 => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR]
sgrs
reset :: Text
reset = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]
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 -> 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
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_ (String -> IO ()
putStrLn 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
PackageName -> (Version -> Bool) -> [Tool] -> [PackageIdentifier]
filterTools (String -> PackageName
mkPackageName String
pkgName) (forall a b. a -> b -> a
const Bool
True) [Tool]
installed