{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Ls
( LsCmdOpts (..)
, LsCmds (..)
, SnapshotOpts (..)
, LsView (..)
, ListDepsOpts (..)
, ListDepsFormat (..)
, ListDepsFormatOpts (..)
, ListDepsTextFilter (..)
, ListStylesOpts (..)
, ListToolsOpts (..)
, lsCmd
) where
import Data.Aeson ( FromJSON, Value (..), (.:), encode )
import Data.Array.IArray ( (//), elems )
import qualified Data.ByteString.Lazy.Char8 as LBC8
import Distribution.Package ( mkPackageName )
import qualified Data.Aeson.Types as A
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Text ( isPrefixOf )
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.DependencyGraph ( createPrunedDependencyGraph )
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.DependencyTree
( DependencyTree (..), DotPayload (..), licenseText
, versionText
)
import Stack.Types.DotOpts ( DotOpts (..) )
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 )
newtype LsException
= ParseFailure [Value]
deriving (Int -> LsException -> ShowS
[LsException] -> ShowS
LsException -> [Char]
(Int -> LsException -> ShowS)
-> (LsException -> [Char])
-> ([LsException] -> ShowS)
-> Show LsException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LsException -> ShowS
showsPrec :: Int -> LsException -> ShowS
$cshow :: LsException -> [Char]
show :: LsException -> [Char]
$cshowList :: [LsException] -> ShowS
showList :: [LsException] -> ShowS
Show, Typeable)
instance Exception LsException where
displayException :: LsException -> [Char]
displayException (ParseFailure [Value]
val) =
[Char]
"Error: [S-3421]\n"
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Failure to parse values as a snapshot: "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Value] -> [Char]
forall a. Show a => a -> [Char]
show [Value]
val
newtype LsCmdOpts
= LsCmdOpts { LsCmdOpts -> LsCmds
lsCmds :: LsCmds }
data LsCmds
= LsSnapshot SnapshotOpts
| LsDependencies ListDepsOpts
| LsStyles ListStylesOpts
| LsTools ListToolsOpts
data SnapshotOpts = SnapshotOpts
{ SnapshotOpts -> LsView
viewType :: LsView
, SnapshotOpts -> Bool
ltsSnapView :: Bool
, SnapshotOpts -> Bool
nightlySnapView :: 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, 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, Int -> SnapshotOpts -> ShowS
[SnapshotOpts] -> ShowS
SnapshotOpts -> [Char]
(Int -> SnapshotOpts -> ShowS)
-> (SnapshotOpts -> [Char])
-> ([SnapshotOpts] -> ShowS)
-> Show SnapshotOpts
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotOpts -> ShowS
showsPrec :: Int -> SnapshotOpts -> ShowS
$cshow :: SnapshotOpts -> [Char]
show :: SnapshotOpts -> [Char]
$cshowList :: [SnapshotOpts] -> ShowS
showList :: [SnapshotOpts] -> ShowS
Show)
data LsView
= Local
| Remote
deriving (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, Int -> LsView -> ShowS
[LsView] -> ShowS
LsView -> [Char]
(Int -> LsView -> ShowS)
-> (LsView -> [Char]) -> ([LsView] -> ShowS) -> Show LsView
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LsView -> ShowS
showsPrec :: Int -> LsView -> ShowS
$cshow :: LsView -> [Char]
show :: LsView -> [Char]
$cshowList :: [LsView] -> ShowS
showList :: [LsView] -> ShowS
Show)
data SnapshotType
= Lts
| Nightly
deriving (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, Int -> SnapshotType -> ShowS
[SnapshotType] -> ShowS
SnapshotType -> [Char]
(Int -> SnapshotType -> ShowS)
-> (SnapshotType -> [Char])
-> ([SnapshotType] -> ShowS)
-> Show SnapshotType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotType -> ShowS
showsPrec :: Int -> SnapshotType -> ShowS
$cshow :: SnapshotType -> [Char]
show :: SnapshotType -> [Char]
$cshowList :: [SnapshotType] -> ShowS
showList :: [SnapshotType] -> ShowS
Show)
data ListDepsOpts = ListDepsOpts
{ ListDepsOpts -> ListDepsFormat
format :: !ListDepsFormat
, ListDepsOpts -> DotOpts
dotOpts :: !DotOpts
}
data ListDepsFormat
= ListDepsText ListDepsFormatOpts [ListDepsTextFilter]
| ListDepsTree ListDepsFormatOpts
| ListDepsJSON
| ListDepsConstraints
data ListDepsFormatOpts = ListDepsFormatOpts
{ ListDepsFormatOpts -> Text
sep :: !Text
, ListDepsFormatOpts -> Bool
license :: !Bool
}
data ListDepsTextFilter
= FilterPackage PackageName
| FilterLocals
data ListStylesOpts = ListStylesOpts
{ ListStylesOpts -> Bool
basic :: Bool
, ListStylesOpts -> Bool
sgr :: Bool
, ListStylesOpts -> Bool
example :: 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 -> [Char]
(Int -> ListStylesOpts -> ShowS)
-> (ListStylesOpts -> [Char])
-> ([ListStylesOpts] -> ShowS)
-> Show ListStylesOpts
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListStylesOpts -> ShowS
showsPrec :: Int -> ListStylesOpts -> ShowS
$cshow :: ListStylesOpts -> [Char]
show :: ListStylesOpts -> [Char]
$cshowList :: [ListStylesOpts] -> ShowS
showList :: [ListStylesOpts] -> ShowS
Show)
newtype ListToolsOpts
= ListToolsOpts { ListToolsOpts -> [Char]
filter :: String }
data Snapshot = Snapshot
{ Snapshot -> Text
snapId :: Text
, Snapshot -> Text
title :: Text
, Snapshot -> Text
time :: Text
}
deriving (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, Int -> Snapshot -> ShowS
[Snapshot] -> ShowS
Snapshot -> [Char]
(Int -> Snapshot -> ShowS)
-> (Snapshot -> [Char]) -> ([Snapshot] -> ShowS) -> Show Snapshot
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Snapshot -> ShowS
showsPrec :: Int -> Snapshot -> ShowS
$cshow :: Snapshot -> [Char]
show :: Snapshot -> [Char]
$cshowList :: [Snapshot] -> ShowS
showList :: [Snapshot] -> ShowS
Show)
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 a. Monoid a => a
mempty
data SnapshotData = SnapshotData
{ SnapshotData -> Integer
_snapTotalCounts :: Integer
, SnapshotData -> [[Snapshot]]
snaps :: [[Snapshot]]
}
deriving (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, Int -> SnapshotData -> ShowS
[SnapshotData] -> ShowS
SnapshotData -> [Char]
(Int -> SnapshotData -> ShowS)
-> (SnapshotData -> [Char])
-> ([SnapshotData] -> ShowS)
-> Show SnapshotData
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotData -> ShowS
showsPrec :: Int -> SnapshotData -> ShowS
$cshow :: SnapshotData -> [Char]
show :: SnapshotData -> [Char]
$cshowList :: [SnapshotData] -> ShowS
showList :: [SnapshotData] -> ShowS
Show)
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 a. Monoid a => a
mempty
toSnapshot :: [Value] -> Snapshot
toSnapshot :: [Value] -> Snapshot
toSnapshot [String Text
snapId, String Text
title, String Text
time] =
Snapshot
{ Text
$sel:snapId:Snapshot :: Text
snapId :: Text
snapId
, Text
$sel:title:Snapshot :: Text
title :: Text
title
, Text
$sel:time:Snapshot :: Text
time :: Text
time
}
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 = [Char] -> (Array -> Parser Snapshot) -> Value -> Parser Snapshot
forall a. [Char] -> (Array -> Parser a) -> Value -> Parser a
A.withArray [Char]
"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
snap = [Snapshot
snap.time]
displaySnap :: Snapshot -> [Text]
displaySnap :: Snapshot -> [Text]
displaySnap Snapshot
snap =
[Text
"Resolver name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Snapshot
snap.snapId, Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Snapshot
snap.title 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 a. Monoid a => a
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 SnapshotData
sdata.snaps 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 = filterSnapData }
where
snapdata :: [[Snapshot]]
snapdata = SnapshotData
sdata.snaps
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
x.snapId)) [[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
x.snapId)) [[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" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Char] -> Text) -> [[Char]] -> [Text]
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) <-
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
[[Char]]
snapData' <- IO [[Char]] -> RIO Runner [[Char]]
forall a. IO a -> RIO Runner a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> RIO Runner [[Char]])
-> IO [[Char]] -> RIO Runner [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [[Char]]
listDirectory ([Char] -> IO [[Char]]) -> [Char] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
snapRootDir
let snapData :: [[Char]]
snapData = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
L.sort [[Char]]
snapData'
case LsCmdOpts
lsOpts.lsCmds of
LsSnapshot SnapshotOpts
sopt ->
case (SnapshotOpts
sopt.ltsSnapView, SnapshotOpts
sopt.nightlySnapView) 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 -> [[Char]] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$
([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf [Char]
"lts") [[Char]]
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 -> [[Char]] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$
([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf [Char]
"night") [[Char]]
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 -> [[Char]] -> IO ()
displayLocalSnapshot Bool
isStdoutTerminal [[Char]]
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
$ [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
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
lsOpts.lsCmds of
LsSnapshot SnapshotOpts
sopt ->
case (SnapshotOpts
sopt.ltsSnapView, SnapshotOpts
sopt.nightlySnapView) 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 :: [Char]
urlInfo = [Char]
"https://www.stackage.org/snapshots"
lsCmd :: LsCmdOpts -> RIO Runner ()
lsCmd :: LsCmdOpts -> RIO Runner ()
lsCmd LsCmdOpts
lsOpts =
case LsCmdOpts
lsOpts.lsCmds of
LsSnapshot SnapshotOpts
sopt ->
case SnapshotOpts
sopt.viewType 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
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
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
opts.basic
showSGR :: Bool
showSGR = Bool
isComplex Bool -> Bool -> Bool
&& ListStylesOpts
opts.sgr
showExample :: Bool
showExample = Bool
isComplex Bool -> Bool -> Bool
&& ListStylesOpts
opts.example 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 a. Monoid a => a
mempty)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
showExample then Text
example else Text
forall a. Monoid a => a
mempty)
where
codes :: Text
codes = Text -> [Text] -> Text
T.intercalate Text
";" ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map ([Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> (Int -> [Char]) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
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 ([Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> (SGR -> [Char]) -> SGR -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SGR -> [Char]
forall a. Show a => a -> [Char]
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 = [Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [SGR] -> [Char]
setSGRCode [SGR]
sgrs
reset :: Text
reset = [Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [SGR] -> [Char]
setSGRCode [SGR
Reset]
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 (.localPrograms)
[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
opts.filter 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
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_ ([Char] -> IO ()
putStrLn ([Char] -> IO ()) -> (Tool -> [Char]) -> Tool -> IO ()
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 (PackageIdentifier -> Tool) -> [PackageIdentifier] -> [Tool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
PackageName -> (Version -> Bool) -> [Tool] -> [PackageIdentifier]
filterTools ([Char] -> PackageName
mkPackageName [Char]
pkgName) (Bool -> Version -> Bool
forall a b. a -> b -> a
const Bool
True) [Tool]
installed
listDependencies :: ListDepsOpts -> RIO Runner ()
listDependencies :: ListDepsOpts -> RIO Runner ()
listDependencies ListDepsOpts
opts = do
let dotOpts :: DotOpts
dotOpts = ListDepsOpts
opts.dotOpts
(Set PackageName
pkgs, Map PackageName (Set PackageName, DotPayload)
resultGraph) <- DotOpts
-> RIO
Runner
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts
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
$ case ListDepsOpts
opts.format of
ListDepsTree ListDepsFormatOpts
treeOpts ->
Text -> IO ()
T.putStrLn Text
"Packages"
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
treeOpts DotOpts
dotOpts Int
0 [] (ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots ListDepsOpts
opts Set PackageName
pkgs) Map PackageName (Set PackageName, DotPayload)
resultGraph
ListDepsFormat
ListDepsJSON -> Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> IO ()
printJSON Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
resultGraph
ListDepsText ListDepsFormatOpts
textOpts [ListDepsTextFilter]
listDepsTextFilters -> do
let resultGraph' :: Map PackageName (Set PackageName, DotPayload)
resultGraph' = (PackageName -> (Set PackageName, DotPayload) -> Bool)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey PackageName -> (Set PackageName, DotPayload) -> Bool
forall {p}. PackageName -> p -> Bool
p Map PackageName (Set PackageName, DotPayload)
resultGraph
p :: PackageName -> p -> Bool
p PackageName
k p
_ =
PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember PackageName
k ([PackageName] -> [ListDepsTextFilter] -> Set PackageName
exclude (Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
pkgs) [ListDepsTextFilter]
listDepsTextFilters)
IO (Map PackageName ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Map PackageName ()) -> IO ())
-> IO (Map PackageName ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PackageName -> DotPayload -> IO ())
-> Map PackageName DotPayload -> IO (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (Text -> ListDepsFormatOpts -> PackageName -> DotPayload -> IO ()
go Text
"" ListDepsFormatOpts
textOpts) ((Set PackageName, DotPayload) -> DotPayload
forall a b. (a, b) -> b
snd ((Set PackageName, DotPayload) -> DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName DotPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
resultGraph')
where
exclude :: [PackageName] -> [ListDepsTextFilter] -> Set PackageName
exclude :: [PackageName] -> [ListDepsTextFilter] -> Set PackageName
exclude [PackageName]
locals = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> ([ListDepsTextFilter] -> [PackageName])
-> [ListDepsTextFilter]
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageName] -> [ListDepsTextFilter] -> [PackageName]
exclude' [PackageName]
locals
exclude' :: [PackageName] -> [ListDepsTextFilter] -> [PackageName]
exclude' :: [PackageName] -> [ListDepsTextFilter] -> [PackageName]
exclude' [PackageName]
_ [] = []
exclude' [PackageName]
locals (ListDepsTextFilter
f:[ListDepsTextFilter]
fs) = case ListDepsTextFilter
f of
FilterPackage PackageName
pkgName -> PackageName
pkgName PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
: [PackageName] -> [ListDepsTextFilter] -> [PackageName]
exclude' [PackageName]
locals [ListDepsTextFilter]
fs
ListDepsTextFilter
FilterLocals -> [PackageName]
locals [PackageName] -> [PackageName] -> [PackageName]
forall a. Semigroup a => a -> a -> a
<> [PackageName] -> [ListDepsTextFilter] -> [PackageName]
exclude' [PackageName]
locals [ListDepsTextFilter]
fs
ListDepsFormat
ListDepsConstraints -> do
let constraintOpts :: ListDepsFormatOpts
constraintOpts = Text -> Bool -> ListDepsFormatOpts
ListDepsFormatOpts Text
" ==" Bool
False
Text -> IO ()
T.putStrLn Text
"constraints:"
IO (Map PackageName ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Map PackageName ()) -> IO ())
-> IO (Map PackageName ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PackageName -> DotPayload -> IO ())
-> Map PackageName DotPayload -> IO (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (Text -> ListDepsFormatOpts -> PackageName -> DotPayload -> IO ()
go Text
" , " ListDepsFormatOpts
constraintOpts)
((Set PackageName, DotPayload) -> DotPayload
forall a b. (a, b) -> b
snd ((Set PackageName, DotPayload) -> DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName DotPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
resultGraph)
where
go :: Text -> ListDepsFormatOpts -> PackageName -> DotPayload -> IO ()
go Text
prefix ListDepsFormatOpts
lineOpts PackageName
name DotPayload
payload =
Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
lineOpts PackageName
name DotPayload
payload
treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots ListDepsOpts
opts Set PackageName
projectPackages' =
let targets :: [Text]
targets = ListDepsOpts
opts.dotOpts.dotTargets
in if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targets
then Set PackageName
projectPackages'
else [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (Text -> PackageName) -> [Text] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> PackageName
mkPackageName ([Char] -> PackageName) -> (Text -> [Char]) -> Text -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) [Text]
targets
printTree ::
ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
remainingDepsCounts Set PackageName
packages Map PackageName (Set PackageName, DotPayload)
dependencyMap =
Seq (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
F.sequence_ (Seq (IO ()) -> IO ()) -> Seq (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> PackageName -> IO ()) -> Seq PackageName -> Seq (IO ())
forall a b. (Int -> a -> b) -> Seq a -> Seq b
Seq.mapWithIndex Int -> PackageName -> IO ()
go (Set PackageName -> Seq PackageName
forall {a}. Set a -> Seq a
toSeq Set PackageName
packages)
where
toSeq :: Set a -> Seq a
toSeq = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> (Set a -> [a]) -> Set a -> Seq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
go :: Int -> PackageName -> IO ()
go Int
index PackageName
name =
let newDepsCounts :: [Int]
newDepsCounts = [Int]
remainingDepsCounts [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Set PackageName -> Int
forall a. Set a -> Int
Set.size Set PackageName
packages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
in case PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> Maybe (Set PackageName, DotPayload)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Set PackageName, DotPayload)
dependencyMap of
Just (Set PackageName
deps, DotPayload
payload) -> do
ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
newDepsCounts Set PackageName
deps DotPayload
payload PackageName
name
if Int -> Maybe Int
forall a. a -> Maybe a
Just Int
depth Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== DotOpts
dotOpts.dependencyDepth
then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
opts DotOpts
dotOpts (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
newDepsCounts Set PackageName
deps
Map PackageName (Set PackageName, DotPayload)
dependencyMap
Maybe (Set PackageName, DotPayload)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
printTreeNode ::
ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
remainingDepsCounts Set PackageName
deps DotPayload
payload PackageName
name =
let remainingDepth :: Int
remainingDepth = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
999 DotOpts
dotOpts.dependencyDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
depth
hasDeps :: Bool
hasDeps = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageName -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
deps
in Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix Text
"" [Int]
remainingDepsCounts Bool
hasDeps Int
remainingDepth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
opts PackageName
name DotPayload
payload
treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix Text
t [] Bool
_ Int
_ = Text
t
treeNodePrefix Text
t [Int
0] Bool
True Int
0 = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└──"
treeNodePrefix Text
t [Int
_] Bool
True Int
0 = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├──"
treeNodePrefix Text
t [Int
0] Bool
True Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└─┬"
treeNodePrefix Text
t [Int
_] Bool
True Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├─┬"
treeNodePrefix Text
t [Int
0] Bool
False Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└──"
treeNodePrefix Text
t [Int
_] Bool
False Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├──"
treeNodePrefix Text
t (Int
0:[Int]
ns) Bool
d Int
remainingDepth = Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ") [Int]
ns Bool
d Int
remainingDepth
treeNodePrefix Text
t (Int
_:[Int]
ns) Bool
d Int
remainingDepth = Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"│ ") [Int]
ns Bool
d Int
remainingDepth
listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
opts PackageName
name DotPayload
payload =
[Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts
opts.sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
ListDepsFormatOpts -> DotPayload -> Text
payloadText ListDepsFormatOpts
opts DotPayload
payload
payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText ListDepsFormatOpts
opts DotPayload
payload =
if ListDepsFormatOpts
opts.license
then DotPayload -> Text
licenseText DotPayload
payload
else DotPayload -> Text
versionText DotPayload
payload
printJSON ::
Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printJSON :: Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> IO ()
printJSON Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
dependencyMap =
ByteString -> IO ()
LBC8.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ DependencyTree -> ByteString
forall a. ToJSON a => a -> ByteString
encode (DependencyTree -> ByteString) -> DependencyTree -> ByteString
forall a b. (a -> b) -> a -> b
$ Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> DependencyTree
DependencyTree Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
dependencyMap