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

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

module Stack.IDE
  ( OutputStream (..)
  , ListPackagesCmd (..)
  , idePackagesCmd
  , ideTargetsCmd
  , listPackages
  , listTargets
  ) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           Data.Tuple ( swap )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withBuildConfig, withConfig )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.NamedComponent
                   ( NamedComponent, isCBench, isCExe, isCTest
                   , renderPkgComponent
                   )
import           Stack.Types.Runner ( Runner )
import           Stack.Types.SourceMap
                   ( ProjectPackage (..), SMWanted (..), ppComponentsMaybe )
import           System.IO ( putStrLn )

-- Type representing output stream choices for the @stack ide packages@ and

-- @stack ide targets@ commands.

data OutputStream
  = OutputLogInfo
    -- ^ To the same output stream as other log information.

  | OutputStdout
    -- ^ To the standard output stream.


-- Type representing output choices for the @stack ide packages@ command.

data ListPackagesCmd
  = ListPackageNames
    -- ^ Package names.

  | ListPackageCabalFiles
    -- ^ Paths to Cabal files.


-- | Function underlying the @stack ide packages@ command. List packages in the

-- project.

idePackagesCmd :: (OutputStream, ListPackagesCmd) -> RIO Runner ()
idePackagesCmd :: (OutputStream, ListPackagesCmd) -> RIO Runner ()
idePackagesCmd =
  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ())
-> ((OutputStream, ListPackagesCmd) -> RIO Config ())
-> (OutputStream, ListPackagesCmd)
-> RIO Runner ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RIO BuildConfig () -> RIO Config ()
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig (RIO BuildConfig () -> RIO Config ())
-> ((OutputStream, ListPackagesCmd) -> RIO BuildConfig ())
-> (OutputStream, ListPackagesCmd)
-> RIO Config ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputStream -> ListPackagesCmd -> RIO BuildConfig ())
-> (OutputStream, ListPackagesCmd) -> RIO BuildConfig ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry OutputStream -> ListPackagesCmd -> RIO BuildConfig ()
forall env.
HasBuildConfig env =>
OutputStream -> ListPackagesCmd -> RIO env ()
listPackages

compTypes :: (Bool, Bool, Bool) -> NamedComponent -> Bool
compTypes :: (Bool, Bool, Bool) -> NamedComponent -> Bool
compTypes (Bool
False, Bool
False, Bool
False) = Bool -> NamedComponent -> Bool
forall a b. a -> b -> a
const Bool
True
compTypes (Bool
exe, Bool
test, Bool
bench) =
  \NamedComponent
x -> (Bool
exe Bool -> Bool -> Bool
&& NamedComponent -> Bool
isCExe NamedComponent
x) Bool -> Bool -> Bool
|| (Bool
test Bool -> Bool -> Bool
&& NamedComponent -> Bool
isCTest NamedComponent
x) Bool -> Bool -> Bool
|| (Bool
bench Bool -> Bool -> Bool
&& NamedComponent -> Bool
isCBench NamedComponent
x)

-- | Function underlying the @stack ide targets@ command. List targets in the

-- project.

ideTargetsCmd :: ((Bool, Bool, Bool), OutputStream)  -> RIO Runner ()
ideTargetsCmd :: ((Bool, Bool, Bool), OutputStream) -> RIO Runner ()
ideTargetsCmd = ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ())
-> (((Bool, Bool, Bool), OutputStream) -> RIO Config ())
-> ((Bool, Bool, Bool), OutputStream)
-> RIO Runner ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  RIO BuildConfig () -> RIO Config ()
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig (RIO BuildConfig () -> RIO Config ())
-> (((Bool, Bool, Bool), OutputStream) -> RIO BuildConfig ())
-> ((Bool, Bool, Bool), OutputStream)
-> RIO Config ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputStream -> (NamedComponent -> Bool) -> RIO BuildConfig ())
-> (OutputStream, NamedComponent -> Bool) -> RIO BuildConfig ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry OutputStream -> (NamedComponent -> Bool) -> RIO BuildConfig ()
forall env.
HasBuildConfig env =>
OutputStream -> (NamedComponent -> Bool) -> RIO env ()
listTargets ((OutputStream, NamedComponent -> Bool) -> RIO BuildConfig ())
-> (((Bool, Bool, Bool), OutputStream)
    -> (OutputStream, NamedComponent -> Bool))
-> ((Bool, Bool, Bool), OutputStream)
-> RIO BuildConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Bool, Bool) -> NamedComponent -> Bool)
-> (OutputStream, (Bool, Bool, Bool))
-> (OutputStream, NamedComponent -> Bool)
forall a b. (a -> b) -> (OutputStream, a) -> (OutputStream, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Bool, Bool) -> NamedComponent -> Bool
compTypes ((OutputStream, (Bool, Bool, Bool))
 -> (OutputStream, NamedComponent -> Bool))
-> (((Bool, Bool, Bool), OutputStream)
    -> (OutputStream, (Bool, Bool, Bool)))
-> ((Bool, Bool, Bool), OutputStream)
-> (OutputStream, NamedComponent -> Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Bool, Bool), OutputStream)
-> (OutputStream, (Bool, Bool, Bool))
forall a b. (a, b) -> (b, a)
swap

outputFunc :: HasTerm env => OutputStream -> String -> RIO env ()
outputFunc :: forall env. HasTerm env => OutputStream -> String -> RIO env ()
outputFunc OutputStream
OutputLogInfo = StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ())
-> (String -> StyleDoc) -> String -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString
outputFunc OutputStream
OutputStdout  = IO () -> RIO env ()
forall a. IO a -> RIO env a
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

-- | List the packages inside the current project.

listPackages ::
     HasBuildConfig env
  => OutputStream
  -> ListPackagesCmd
  -> RIO env ()
listPackages :: forall env.
HasBuildConfig env =>
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
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. HasTerm env => OutputStream -> String -> RIO env ()
outputFunc OutputStream
stream) [String]
strs

-- | List the targets in the current project.

listTargets ::
     forall env. HasBuildConfig env
  => OutputStream
  -> (NamedComponent -> Bool)
  -> RIO env ()
listTargets :: forall env.
HasBuildConfig env =>
OutputStream -> (NamedComponent -> Bool) -> RIO env ()
listTargets OutputStream
stream NamedComponent -> Bool
isCompType = 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
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. HasTerm 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 a b. (a -> b) -> RIO env a -> RIO env b
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
. (NamedComponent -> Maybe NamedComponent)
-> ProjectPackage -> RIO env (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
(NamedComponent -> Maybe NamedComponent)
-> ProjectPackage -> m (Set NamedComponent)
ppComponentsMaybe (\NamedComponent
x ->
      if NamedComponent -> Bool
isCompType NamedComponent
x then NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
x else Maybe NamedComponent
forall a. Maybe a
Nothing)