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
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
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)
= ( 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