123 lines
4.6 KiB
Haskell
123 lines
4.6 KiB
Haskell
-- | 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.Internal.Monadic
|
|
import UI.Butcher.Internal.MonadicTypes
|
|
import UI.Butcher.Monadic.Param
|
|
import UI.Butcher.Monadic.Pretty
|
|
|
|
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 cmd = do
|
|
progName <- System.Environment.getProgName
|
|
case toCmdDesc (Just progName) cmd of
|
|
Left e -> do
|
|
putStrErrLn
|
|
$ progName
|
|
++ ": internal error: failed sanity check for butcher main command parser!"
|
|
putStrErrLn $ "(" ++ e ++ ")"
|
|
putStrErrLn $ "aborting."
|
|
Right fullDesc -> do
|
|
args <- System.Environment.getArgs
|
|
case runCmdParserCoreFromDesc fullDesc (InputArgs args) cmd of
|
|
(desc, _, Left err) -> do
|
|
putStrErrLn
|
|
$ progName
|
|
++ ": error parsing arguments: "
|
|
++ case _pe_messages err of
|
|
[] -> ""
|
|
(m : _) -> m
|
|
putStrErrLn $ case _pe_remaining err of
|
|
InputString "" -> "at the end of input."
|
|
InputString str -> case show str of
|
|
s | length s < 42 -> "at: " ++ s ++ "."
|
|
s -> "at: " ++ take 40 s ++ "..\"."
|
|
InputArgs [] -> "at the end of input"
|
|
InputArgs xs -> case List.unwords $ show <$> xs of
|
|
s | length s < 42 -> "at: " ++ s ++ "."
|
|
s -> "at: " ++ take 40 s ++ "..\"."
|
|
putStrErrLn $ "usage:"
|
|
printErr $ ppUsage desc
|
|
(desc, _, Right out) -> case out of
|
|
Nothing -> do
|
|
putStrErrLn $ "usage:"
|
|
printErr $ ppUsage desc
|
|
Just a -> 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 cmdF = do
|
|
progName <- System.Environment.getProgName
|
|
let (checkResult, optimisticFullDesc) =
|
|
( toCmdDesc (Just progName) (cmdF optimisticFullDesc)
|
|
, either (const emptyCommandDesc) id $ checkResult
|
|
)
|
|
-- knot-tying at its finest..
|
|
case checkResult of
|
|
Left e -> do
|
|
putStrErrLn
|
|
$ progName
|
|
++ ": internal error: failed sanity check for butcher main command parser!"
|
|
putStrErrLn $ "(" ++ e ++ ")"
|
|
putStrErrLn $ "aborting."
|
|
Right fullDesc -> do
|
|
args <- System.Environment.getArgs
|
|
case runCmdParserCoreFromDesc fullDesc (InputArgs args) (cmdF fullDesc) of
|
|
(desc, _, Left err) -> do
|
|
putStrErrLn $ progName ++ ": error parsing arguments: " ++ head
|
|
(_pe_messages err)
|
|
putStrErrLn $ case _pe_remaining err of
|
|
InputString "" -> "at the end of input."
|
|
InputString str -> case show str of
|
|
s | length s < 42 -> "at: " ++ s ++ "."
|
|
s -> "at: " ++ take 40 s ++ "..\"."
|
|
InputArgs [] -> "at the end of input"
|
|
InputArgs xs -> case List.unwords $ show <$> xs of
|
|
s | length s < 42 -> "at: " ++ s ++ "."
|
|
s -> "at: " ++ take 40 s ++ "..\"."
|
|
putStrErrLn $ "usage:"
|
|
printErr $ ppUsage desc
|
|
(desc, _, Right out) -> case out of
|
|
Nothing -> do
|
|
putStrErrLn $ "usage:"
|
|
printErr $ ppUsage desc
|
|
Just a -> a
|
|
|
|
putStrErrLn :: String -> IO ()
|
|
putStrErrLn s = hPutStrLn stderr s
|
|
|
|
printErr :: Show a => a -> IO ()
|
|
printErr = putStrErrLn . show
|