{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.IDE
( OutputStream(..)
, ListPackagesCmd(..)
, listPackages
, listTargets
) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Stack.Prelude
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.SourceMap
import System.IO (putStrLn)
data OutputStream = OutputLogInfo
| OutputStdout
data ListPackagesCmd = ListPackageNames
| ListPackageCabalFiles
outputFunc :: HasLogFunc env => OutputStream -> String -> RIO env ()
outputFunc :: OutputStream -> String -> RIO env ()
outputFunc OutputStream
OutputLogInfo = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (String -> Utf8Builder) -> String -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8Builder
forall a. IsString a => String -> a
fromString
outputFunc OutputStream
OutputStdout = IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> (String -> IO ()) -> String -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
listPackages :: HasBuildConfig env => OutputStream -> ListPackagesCmd -> RIO env ()
listPackages :: OutputStream -> ListPackagesCmd -> RIO env ()
listPackages OutputStream
stream ListPackagesCmd
flag = do
Map PackageName ProjectPackage
packages <- Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage))
-> Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL((BuildConfig
-> Const (Map PackageName ProjectPackage) BuildConfig)
-> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
-> Const
(Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
-> BuildConfig
-> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
let strs :: [String]
strs = case ListPackagesCmd
flag of
ListPackagesCmd
ListPackageNames ->
(PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString (Map PackageName ProjectPackage -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
packages)
ListPackagesCmd
ListPackageCabalFiles ->
(ProjectPackage -> String) -> [ProjectPackage] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> (ProjectPackage -> Path Abs File) -> ProjectPackage -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> Path Abs File
ppCabalFP) (Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages)
(String -> RIO env ()) -> [String] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (OutputStream -> String -> RIO env ()
forall env. HasLogFunc env => OutputStream -> String -> RIO env ()
outputFunc OutputStream
stream) [String]
strs
listTargets :: forall env. HasBuildConfig env => OutputStream -> RIO env ()
listTargets :: OutputStream -> RIO env ()
listTargets OutputStream
stream = do
Map PackageName ProjectPackage
packages <- Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage))
-> Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL((BuildConfig
-> Const (Map PackageName ProjectPackage) BuildConfig)
-> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
-> Const
(Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
-> BuildConfig
-> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
[(PackageName, NamedComponent)]
pairs <- Map PackageName [(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map PackageName [(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)])
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
-> RIO env [(PackageName, NamedComponent)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName
-> ProjectPackage -> RIO env [(PackageName, NamedComponent)])
-> Map PackageName ProjectPackage
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PackageName
-> ProjectPackage -> RIO env [(PackageName, NamedComponent)]
toNameAndComponent Map PackageName ProjectPackage
packages
OutputStream -> String -> RIO env ()
forall env. HasLogFunc env => OutputStream -> String -> RIO env ()
outputFunc OutputStream
stream (String -> RIO env ()) -> String -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
((PackageName, NamedComponent) -> Text)
-> [(PackageName, NamedComponent)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> Text
renderPkgComponent [(PackageName, NamedComponent)]
pairs
where
toNameAndComponent
:: PackageName
-> ProjectPackage
-> RIO env [(PackageName, NamedComponent)]
toNameAndComponent :: PackageName
-> ProjectPackage -> RIO env [(PackageName, NamedComponent)]
toNameAndComponent PackageName
pkgName' =
(Set NamedComponent -> [(PackageName, NamedComponent)])
-> RIO env (Set NamedComponent)
-> RIO env [(PackageName, NamedComponent)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NamedComponent -> (PackageName, NamedComponent))
-> [NamedComponent] -> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName
pkgName', ) ([NamedComponent] -> [(PackageName, NamedComponent)])
-> (Set NamedComponent -> [NamedComponent])
-> Set NamedComponent
-> [(PackageName, NamedComponent)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList) (RIO env (Set NamedComponent)
-> RIO env [(PackageName, NamedComponent)])
-> (ProjectPackage -> RIO env (Set NamedComponent))
-> ProjectPackage
-> RIO env [(PackageName, NamedComponent)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> RIO env (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents