module System.Console.Command
(
Commands,Tree.Tree(Tree.Node)
, Command(Command,name,description,action,shorten)
, command
, Action
, io
, withNonOption
, withOption
, ignoreOption
) where
import System.Console.Internal
(
Command(Command,name,description,action,shorten)
, Action(Action,run,options,nonOptions,ignoringOptions)
, Option(Option)
, Identifier
, ConsoleProgramException(UnknownCommand)
)
import qualified System.Console.Argument as Argument
import Control.Exception (throwIO)
import Control.Monad.IO.Class (MonadIO,liftIO)
import qualified Data.Map as Map
import qualified Data.Tree as Tree
import System.Exit (exitFailure)
type Commands m
= Tree.Tree (Command m)
command :: String -> String -> Action m -> Command m
command n d a = Command { name = n, description = d, action = a, shorten = True }
allowShort :: Bool -> Command m -> Command m
allowShort b c = c { shorten = b }
io :: (MonadIO m) => m () -> Action m
io h = Action r [] [] [] where
r [] _ = h
r rest _ = liftIO . throwIO . UnknownCommand $ unwords rest
withNonOption :: (MonadIO m) => Argument.Type x -> (x -> Action m) -> Action m
withNonOption argumentType f = Action
{
run = \ nonOpts opts -> case nonOpts of
(x : xs) -> case Argument.parser argumentType x of
Left e -> liftIO $ do
putStrLn e
exitFailure
Right y -> run (f y) xs opts
[] -> case Argument.defaultValue argumentType of
Nothing -> liftIO $ do
putStrLn $ "Error: missing argument of type " ++ Argument.name argumentType
exitFailure
Just y -> run (f y) [] opts
, nonOptions = Argument.name argumentType : nonOptions (f undefined)
, options = options (f undefined)
, ignoringOptions = ignoringOptions (f undefined)
}
withOption :: (MonadIO m) => Option a -> (a -> Action m) -> Action m
withOption (Option identifier optDescr def p) f = Action
{
run = \ nonOpts opts -> case maybe (Right def) p $ Map.lookup identifier opts of
Left e -> liftIO $ putStrLn e >> exitFailure
Right a -> run (f a) nonOpts opts
, nonOptions = nonOptions (f undefined)
, options = optDescr : options (f undefined)
, ignoringOptions = ignoringOptions (f undefined)
}
ignoreOption :: Option a -> Action m -> Action m
ignoreOption (Option _ g _ _) a = a
{
ignoringOptions = g : ignoringOptions a
}