{-# LANGUAGE GADTs #-}

-- | Dispatch for running all the CLI commands
module Bcc.CLI.Run
  ( ClientCommand(..)
  , ClientCommandErrors
  , renderClientCommandError
  , runClientCommand
  ) where

import           Bcc.Prelude

import           Control.Monad.Trans.Except.Extra (firstExceptT)
import           Data.String
import qualified Data.Text as Text
import qualified Data.Text.IO as Text

import           Bcc.CLI.Cole.Commands (ColeCommand)
import           Bcc.CLI.Cole.Run (ColeClientCmdError, renderColeClientCmdError,
                   runColeClientCommand)
import           Bcc.CLI.Sophie.Commands (SophieCommand)
import           Bcc.CLI.Sophie.Run (SophieClientCmdError, renderSophieClientCmdError,
                   runSophieClientCommand)

import           Bcc.CLI.Render (customRenderHelp)

import           Bcc.Config.Git.Rev (gitRev)
import           Data.Version (showVersion)
import           Paths_bcc_cli (version)
import           System.Info (arch, compilerName, compilerVersion, os)
import           Options.Applicative.Types (Option (..), OptReader (..), Parser (..), ParserInfo (..), ParserPrefs (..))
import           Options.Applicative.Help.Core

import qualified Data.List as L
import qualified System.IO as IO

-- | Sub-commands of 'bcc-cli'.
data ClientCommand =

    -- | Cole Related Commands
    ColeCommand ColeCommand

    -- | Sophie Related Commands
  | SophieCommand SophieCommand

    -- | Sophie-related commands that have been parsed under the
    -- now-deprecated \"sophie\" subcommand.
  | DeprecatedSophieSubcommand SophieCommand

  | forall a. Help ParserPrefs (ParserInfo a)
  | DisplayVersion

data ClientCommandErrors
  = ColeClientError ColeClientCmdError
  | SophieClientError SophieCommand SophieClientCmdError
  deriving Int -> ClientCommandErrors -> ShowS
[ClientCommandErrors] -> ShowS
ClientCommandErrors -> String
(Int -> ClientCommandErrors -> ShowS)
-> (ClientCommandErrors -> String)
-> ([ClientCommandErrors] -> ShowS)
-> Show ClientCommandErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientCommandErrors] -> ShowS
$cshowList :: [ClientCommandErrors] -> ShowS
show :: ClientCommandErrors -> String
$cshow :: ClientCommandErrors -> String
showsPrec :: Int -> ClientCommandErrors -> ShowS
$cshowsPrec :: Int -> ClientCommandErrors -> ShowS
Show

runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
runClientCommand :: ClientCommand -> ExceptT ClientCommandErrors IO ()
runClientCommand (ColeCommand ColeCommand
c) = (ColeClientCmdError -> ClientCommandErrors)
-> ExceptT ColeClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ColeClientCmdError -> ClientCommandErrors
ColeClientError (ExceptT ColeClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT ColeClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ColeCommand -> ExceptT ColeClientCmdError IO ()
runColeClientCommand ColeCommand
c
runClientCommand (SophieCommand SophieCommand
c) = (SophieClientCmdError -> ClientCommandErrors)
-> ExceptT SophieClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (SophieCommand -> SophieClientCmdError -> ClientCommandErrors
SophieClientError SophieCommand
c) (ExceptT SophieClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT SophieClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ SophieCommand -> ExceptT SophieClientCmdError IO ()
runSophieClientCommand SophieCommand
c
runClientCommand (DeprecatedSophieSubcommand SophieCommand
c) =
  (SophieClientCmdError -> ClientCommandErrors)
-> ExceptT SophieClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (SophieCommand -> SophieClientCmdError -> ClientCommandErrors
SophieClientError SophieCommand
c)
    (ExceptT SophieClientCmdError IO ()
 -> ExceptT ClientCommandErrors IO ())
-> ExceptT SophieClientCmdError IO ()
-> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT SophieClientCmdError IO ()
-> ExceptT SophieClientCmdError IO ()
forall (m :: * -> *) e.
MonadIO m =>
ExceptT e m () -> ExceptT e m ()
runSophieClientCommandWithDeprecationWarning
    (ExceptT SophieClientCmdError IO ()
 -> ExceptT SophieClientCmdError IO ())
-> ExceptT SophieClientCmdError IO ()
-> ExceptT SophieClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ SophieCommand -> ExceptT SophieClientCmdError IO ()
runSophieClientCommand SophieCommand
c
runClientCommand (Help ParserPrefs
pprefs ParserInfo a
allParserInfo) = ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
forall a.
ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp ParserPrefs
pprefs ParserInfo a
allParserInfo
runClientCommand ClientCommand
DisplayVersion = ExceptT ClientCommandErrors IO ()
runDisplayVersion

renderClientCommandError :: ClientCommandErrors -> Text
renderClientCommandError :: ClientCommandErrors -> Text
renderClientCommandError (ColeClientError ColeClientCmdError
err) =
  ColeClientCmdError -> Text
renderColeClientCmdError ColeClientCmdError
err
renderClientCommandError (SophieClientError SophieCommand
cmd SophieClientCmdError
err) =
  SophieCommand -> SophieClientCmdError -> Text
renderSophieClientCmdError SophieCommand
cmd SophieClientCmdError
err

-- | Combine an 'ExceptT' that will write a warning message to @stderr@ with
-- the provided 'ExceptT'.
ioExceptTWithWarning :: MonadIO m => Text -> ExceptT e m () -> ExceptT e m ()
ioExceptTWithWarning :: Text -> ExceptT e m () -> ExceptT e m ()
ioExceptTWithWarning Text
warningMsg ExceptT e m ()
e =
  IO () -> ExceptT e m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr Text
warningMsg) ExceptT e m () -> ExceptT e m () -> ExceptT e m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT e m ()
e

-- | Used in the event that Sophie-related commands are run using the
-- now-deprecated \"sophie\" subcommand.
runSophieClientCommandWithDeprecationWarning
  :: MonadIO m
  => ExceptT e m ()
  -> ExceptT e m ()
runSophieClientCommandWithDeprecationWarning :: ExceptT e m () -> ExceptT e m ()
runSophieClientCommandWithDeprecationWarning =
    Text -> ExceptT e m () -> ExceptT e m ()
forall (m :: * -> *) e.
MonadIO m =>
Text -> ExceptT e m () -> ExceptT e m ()
ioExceptTWithWarning Text
warningMsg
  where
    warningMsg :: Text
    warningMsg :: Text
warningMsg =
      Text
"WARNING: The \"sophie\" subcommand is now deprecated and will be "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"removed in the future. Please use the top-level commands instead."

runDisplayVersion :: ExceptT ClientCommandErrors IO ()
runDisplayVersion :: ExceptT ClientCommandErrors IO ()
runDisplayVersion = do
    IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ClientCommandErrors IO ())
-> (Text -> IO ()) -> Text -> ExceptT ClientCommandErrors IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> IO ()
putTextLn (Text -> ExceptT ClientCommandErrors IO ())
-> Text -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"bcc-cli ", Version -> Text
renderVersion Version
version
                , Text
" - ", String -> Text
Text.pack String
os, Text
"-", String -> Text
Text.pack String
arch
                , Text
" - ", String -> Text
Text.pack String
compilerName, Text
"-", Version -> Text
renderVersion Version
compilerVersion
                , Text
"\ngit rev ", Text
gitRev
                ]
  where
    renderVersion :: Version -> Text
renderVersion = String -> Text
Text.pack (String -> Text) -> (Version -> String) -> Version -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version -> String
showVersion


helpAll :: ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll :: ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
progn [String]
rnames ParserInfo a
parserInfo = do
  String -> IO ()
IO.putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ParserHelp -> String
customRenderHelp Int
80 (ParserInfo a -> ParserHelp
usage_help ParserInfo a
parserInfo)
  String -> IO ()
IO.putStrLn String
""
  Parser a -> IO ()
forall a. Parser a -> IO ()
go (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
parserInfo)
  where go :: Parser a -> IO ()
        go :: Parser a -> IO ()
go Parser a
p = case Parser a
p of
          NilP Maybe a
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          OptP Option a
optP -> case Option a -> OptReader a
forall a. Option a -> OptReader a
optMain Option a
optP of
            CmdReader Maybe String
_ [String]
cs String -> Maybe (ParserInfo a)
f -> do
              [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
cs ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
c ->
                Maybe (ParserInfo a) -> (ParserInfo a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> Maybe (ParserInfo a)
f String
c) ((ParserInfo a -> IO ()) -> IO ())
-> (ParserInfo a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ParserInfo a
subParserInfo -> 
                  ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
forall a.
ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
progn (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rnames) ParserInfo a
subParserInfo
            OptReader a
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          AltP Parser a
pa Parser a
pb -> Parser a -> IO ()
forall a. Parser a -> IO ()
go Parser a
pa IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser a -> IO ()
forall a. Parser a -> IO ()
go Parser a
pb
          MultP Parser (x -> a)
pf Parser x
px -> Parser (x -> a) -> IO ()
forall a. Parser a -> IO ()
go Parser (x -> a)
pf IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser x -> IO ()
forall a. Parser a -> IO ()
go Parser x
px
          BindP Parser x
pa x -> Parser a
_ -> Parser x -> IO ()
forall a. Parser a -> IO ()
go Parser x
pa
        usage_help :: ParserInfo a -> ParserHelp
usage_help ParserInfo a
i =
              [ParserHelp] -> ParserHelp
forall a. Monoid a => [a] -> a
mconcat
              [ Chunk Doc -> ParserHelp
usageHelp (Doc -> Chunk Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Chunk Doc) -> ([String] -> Doc) -> [String] -> Chunk Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ParserPrefs -> Parser a -> String -> Doc
forall a. ParserPrefs -> Parser a -> String -> Doc
parserUsage ParserPrefs
pprefs (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i) (String -> Doc) -> ([String] -> String) -> [String] -> Doc
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [String] -> String
L.unwords ([String] -> Chunk Doc) -> [String] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ String
progn String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
forall a. [a] -> [a]
reverse [String]
rnames)
              , Chunk Doc -> ParserHelp
descriptionHelp (ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoProgDesc ParserInfo a
i)
              ]

runHelp :: ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp :: ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO ()
runHelp ParserPrefs
pprefs ParserInfo a
allParserInfo = IO () -> ExceptT ClientCommandErrors IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ClientCommandErrors IO ())
-> IO () -> ExceptT ClientCommandErrors IO ()
forall a b. (a -> b) -> a -> b
$ ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
forall a.
ParserPrefs -> String -> [String] -> ParserInfo a -> IO ()
helpAll ParserPrefs
pprefs String
"bcc-cli" [] ParserInfo a
allParserInfo