-- | 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 cmd :: 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  e :: 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]
++ ": 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
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "aborting."
    Right _ -> 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
        (desc :: CommandDesc ()
desc, Left (ParsingError mess :: [String]
mess remaining :: 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]
++ ": error parsing arguments: "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ case [String]
mess of
                 []    -> ""
                 (m :: String
m:_) -> String
m
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Input
remaining of
            InputString ""  -> "at the end of input."
            InputString str :: String
str -> case String -> String
forall a. Show a => a -> String
show String
str of
              s :: 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
< 42 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
              s :: String
s                 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take 40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..\"."
            InputArgs   []  -> "at the end of input"
            InputArgs   xs :: [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
              s :: 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
< 42 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
              s :: String
s                 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take 40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..\"."
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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
        (desc :: CommandDesc ()
desc, Right out :: CommandDesc (IO ())
out                         ) -> case CommandDesc (IO ()) -> Maybe (IO ())
forall out. CommandDesc out -> Maybe out
_cmd_out CommandDesc (IO ())
out of
          Nothing -> do
            String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 a :: 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 cmdF :: CommandDesc () -> CmdParser Identity (IO ()) ()
cmdF = do
  String
progName <- IO String
System.Environment.getProgName
  let (checkResult :: Either String (CommandDesc ())
checkResult, fullDesc :: 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 e :: 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]
++ ": 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
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
      String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "aborting."
    Right _ -> 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
        (desc :: CommandDesc ()
desc, Left (ParsingError mess :: [String]
mess remaining :: 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]
++ ": 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 "" -> "at the end of input."
            InputString str :: String
str -> case String -> String
forall a. Show a => a -> String
show String
str of
              s :: 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
< 42 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
              s :: String
s -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take 40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..\"."
            InputArgs [] -> "at the end of input"
            InputArgs xs :: [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
              s :: 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
< 42 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
              s :: String
s -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take 40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..\"."
          String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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
        (desc :: CommandDesc ()
desc, Right out :: CommandDesc (IO ())
out) -> case CommandDesc (IO ()) -> Maybe (IO ())
forall out. CommandDesc out -> Maybe out
_cmd_out CommandDesc (IO ())
out of
          Nothing -> do
            String -> IO ()
putStrErrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 a :: IO ()
a -> IO ()
a

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

printErr :: Show a => a -> IO ()
printErr :: 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