-- | Turn your CmdParser into an IO () to be used as your program @main@.
module UI.Butcher.Monadic.IO
  ( mainFromCmdParser
  , mainFromCmdParserWithHelpDesc
  )
where



#include "prelude.inc"
import           Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS

import qualified Text.PrettyPrint as PP

import           Data.HList.ContainsType

import           UI.Butcher.Monadic.Internal.Types
import           UI.Butcher.Monadic.Internal.Core
import           UI.Butcher.Monadic.Pretty
import           UI.Butcher.Monadic.Param

import           System.IO



-- | Utility method that allows using a 'CmdParser' as your @main@ function:
--
-- > main = mainFromCmdParser $ do
-- >   addCmdImpl $ putStrLn "This is a fairly boring program."
--
-- Uses @System.Environment.getProgName@ as program name and
-- @System.Environment.getArgs@ as the input to be parsed. Prints some
-- appropriate messages if parsing fails or if the command has no
-- implementation; if all is well executes the \'out\' action (the IO ()).
mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
mainFromCmdParser CmdParser Identity (IO ()) ()
cmd = do
  String
progName <- IO String
System.Environment.getProgName
  case Maybe String
-> CmdParser Identity (IO ()) () -> Either String (CommandDesc ())
forall (f :: * -> *) out.
Maybe String
-> CmdParser f out () -> Either String (CommandDesc ())
checkCmdParser (String -> Maybe String
forall a. a -> Maybe a
Just String
progName) CmdParser Identity (IO ()) ()
cmd of
    Left  String
e -> do
      String -> IO ()
putStrErrLn
        (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
progName
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": internal error: failed sanity check for butcher main command parser!"
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"aborting."
    Right CommandDesc ()
_ -> do
      [String]
args <- IO [String]
System.Environment.getArgs
      case Maybe String
-> Input
-> CmdParser Identity (IO ()) ()
-> (CommandDesc (), Either ParsingError (CommandDesc (IO ())))
forall out.
Maybe String
-> Input
-> CmdParser Identity out ()
-> (CommandDesc (), Either ParsingError (CommandDesc out))
runCmdParser (String -> Maybe String
forall a. a -> Maybe a
Just String
progName) ([String] -> Input
InputArgs [String]
args) CmdParser Identity (IO ()) ()
cmd of
        (CommandDesc ()
desc, Left (ParsingError [String]
mess Input
remaining)) -> do
          String -> IO ()
putStrErrLn
            (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$  String
progName
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": error parsing arguments: "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ case [String]
mess of
                 []    -> String
""
                 (String
m:[String]
_) -> String
m
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Input
remaining of
            InputString String
""  -> String
"at the end of input."
            InputString String
str -> case String -> String
forall a. Show a => a -> String
show String
str of
              String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
42 -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
              String
s                 -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..\"."
            InputArgs   []  -> String
"at the end of input"
            InputArgs   [String]
xs  -> case [String] -> String
List.unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs of
              String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
42 -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
              String
s                 -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..\"."
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"usage:"
          Doc -> IO ()
forall a. Show a => a -> IO ()
printErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDesc () -> Doc
forall a. CommandDesc a -> Doc
ppUsage CommandDesc ()
desc
        (CommandDesc ()
desc, Right CommandDesc (IO ())
out                         ) -> case CommandDesc (IO ()) -> Maybe (IO ())
forall out. CommandDesc out -> Maybe out
_cmd_out CommandDesc (IO ())
out of
          Maybe (IO ())
Nothing -> do
            String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"usage:"
            Doc -> IO ()
forall a. Show a => a -> IO ()
printErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDesc () -> Doc
forall a. CommandDesc a -> Doc
ppUsage CommandDesc ()
desc
          Just IO ()
a  -> IO ()
a

-- | Same as mainFromCmdParser, but with one additional twist: You get access
-- to a knot-tied complete CommandDesc for this full command. Useful in
-- combination with 'UI.Butcher.Monadic.BuiltinCommands.addHelpCommand'
mainFromCmdParserWithHelpDesc
  :: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
mainFromCmdParserWithHelpDesc :: (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
mainFromCmdParserWithHelpDesc CommandDesc () -> CmdParser Identity (IO ()) ()
cmdF = do
  String
progName <- IO String
System.Environment.getProgName
  let (Either String (CommandDesc ())
checkResult, CommandDesc ()
fullDesc)
        -- knot-tying at its finest..
        = ( Maybe String
-> CmdParser Identity (IO ()) () -> Either String (CommandDesc ())
forall (f :: * -> *) out.
Maybe String
-> CmdParser f out () -> Either String (CommandDesc ())
checkCmdParser (String -> Maybe String
forall a. a -> Maybe a
Just String
progName) (CommandDesc () -> CmdParser Identity (IO ()) ()
cmdF CommandDesc ()
fullDesc)
          , (String -> CommandDesc ())
-> (CommandDesc () -> CommandDesc ())
-> Either String (CommandDesc ())
-> CommandDesc ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CommandDesc () -> String -> CommandDesc ()
forall a b. a -> b -> a
const CommandDesc ()
forall out. CommandDesc out
emptyCommandDesc) CommandDesc () -> CommandDesc ()
forall a. a -> a
id (Either String (CommandDesc ()) -> CommandDesc ())
-> Either String (CommandDesc ()) -> CommandDesc ()
forall a b. (a -> b) -> a -> b
$ Either String (CommandDesc ())
checkResult
          )
  case Either String (CommandDesc ())
checkResult of
    Left String
e -> do
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
progName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": internal error: failed sanity check for butcher main command parser!"
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"aborting."
    Right CommandDesc ()
_ -> do
      [String]
args <- IO [String]
System.Environment.getArgs
      case Maybe String
-> Input
-> CmdParser Identity (IO ()) ()
-> (CommandDesc (), Either ParsingError (CommandDesc (IO ())))
forall out.
Maybe String
-> Input
-> CmdParser Identity out ()
-> (CommandDesc (), Either ParsingError (CommandDesc out))
runCmdParser (String -> Maybe String
forall a. a -> Maybe a
Just String
progName) ([String] -> Input
InputArgs [String]
args) (CommandDesc () -> CmdParser Identity (IO ()) ()
cmdF CommandDesc ()
fullDesc) of
        (CommandDesc ()
desc, Left (ParsingError [String]
mess Input
remaining)) -> do
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
progName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": error parsing arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
mess
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Input
remaining of
            InputString String
"" -> String
"at the end of input."
            InputString String
str -> case String -> String
forall a. Show a => a -> String
show String
str of
              String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
42 -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
              String
s -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..\"."
            InputArgs [] -> String
"at the end of input"
            InputArgs [String]
xs -> case [String] -> String
List.unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs of
              String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
42 -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
              String
s -> String
"at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..\"."
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"usage:"
          Doc -> IO ()
forall a. Show a => a -> IO ()
printErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDesc () -> Doc
forall a. CommandDesc a -> Doc
ppUsage CommandDesc ()
desc
        (CommandDesc ()
desc, Right CommandDesc (IO ())
out) -> case CommandDesc (IO ()) -> Maybe (IO ())
forall out. CommandDesc out -> Maybe out
_cmd_out CommandDesc (IO ())
out of
          Maybe (IO ())
Nothing -> do
            String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"usage:"
            Doc -> IO ()
forall a. Show a => a -> IO ()
printErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDesc () -> Doc
forall a. CommandDesc a -> Doc
ppUsage CommandDesc ()
desc
          Just IO ()
a -> IO ()
a

putStrErrLn :: String -> IO ()
putStrErrLn :: String -> IO ()
putStrErrLn String
s = Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s

printErr :: Show a => a -> IO ()
printErr :: forall a. Show a => a -> IO ()
printErr = String -> IO ()
putStrErrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show