Subcommand.hs

module Stackctl.Subcommand
  ( Subcommand (..)
  , subcommand
  , runSubcommand
  , runSubcommand'
  , runAppSubcommand
  ) where

import Stackctl.Prelude

import qualified Env
import Options.Applicative
import Prettyprinter (pretty, vsep)
import Prettyprinter.Util (reflow)
import Stackctl.AWS (handlingServiceError)
import Stackctl.AutoSSO
import Stackctl.CLI
import Stackctl.ColorOption
import Stackctl.Options
import Stackctl.VerboseOption

data Subcommand options subOptions = Subcommand
  { name :: Text
  , description :: Text
  , parse :: Parser subOptions
  , run :: subOptions -> options -> IO ()
  }

subcommand
  :: Subcommand options subOptions -> Mod CommandFields (options -> IO ())
subcommand Subcommand {..} =
  command (unpack name) (run <$> withInfo description parse)

runSubcommand :: Mod CommandFields (Options -> IO a) -> IO a
runSubcommand =
  runSubcommand' "Work with Stack specifications" envParser optionsParser

-- brittany-disable-next-binding

runSubcommand'
  :: Semigroup options
  => Text
  -> Env.Parser Env.Error options
  -> Parser options
  -> Mod CommandFields (options -> IO a)
  -> IO a
runSubcommand' title parseEnv parseCLI sp = do
  (options, act) <-
    applyEnv
      <$> Env.parse (Env.header $ unpack title) parseEnv
      <*> customExecParser
        (prefs helpShowGlobals)
        (withInfo title $ (,) <$> parseCLI <*> subparser sp)

  act options
 where
  applyEnv env = first (env <>)

-- | Use this in the 'run' member of a 'Subcommand' that wants 'AppT'
--
-- @
--   -- ...
--   , parse = parseFooOptions
--   , run = 'runAppSubcommand' runFoo
--   }
--
-- runFoo :: (MonadReader env m, HasAws env) => FooOptions -> m ()
-- runFoo = undefined
-- @
runAppSubcommand
  :: ( HasColorOption options
     , HasVerboseOption options
     , HasAutoSSOOption options
     )
  => (subOptions -> AppT (App options) IO a)
  -> subOptions
  -> options
  -> IO a
runAppSubcommand f subOptions options =
  runAppT options
    $ handlingServiceError
    $ f subOptions

withInfo :: Text -> Parser a -> ParserInfo a
withInfo d p =
  info (p <**> helper)
    $ progDescDoc
    $ Just
    $ vsep
      [ pretty d
      , ""
      , reflow
          $ "By default, this will operate on the entire stack collection. To"
            <> " operate on a specific stack or set of stacks, use the --filter"
            <> " argument to filter the collection by file path."
      ]