module System.Console.Command
(
Commands,Tree.Tree(Tree.Node)
, Command(Command,name,description,action,shorten)
, command
, Action
, io
, withNonOption
, withNonOptions
, withOption
, ignoreOption
) where
import System.Console.Internal
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)
}
withNonOptions :: (MonadIO m) => Argument.Type x -> ([x] -> Action m) -> Action m
withNonOptions argumentType f = Action
{
run = \ nonOpts opts -> let runWithArgs args [] = run (f $ reverse args) [] opts
runWithArgs args (x:xs) = case Argument.parser argumentType x of
Left e -> liftIO $ do
putStrLn e
exitFailure
Right y -> runWithArgs (y:args) xs
in runWithArgs [] nonOpts
, nonOptions = ("[" ++ Argument.name argumentType ++ "...]") : nonOptions (f [])
, options = options (f [])
, ignoringOptions = ignoringOptions (f [])
}
withOption :: (MonadIO m) => Option a -> (a -> Action m) -> Action m
withOption (Option names optDescr def p) f = Action
{
run = \ nonOpts opts -> case maybe (Right def) p $ Map.lookup (identify names) opts of
Left e -> liftIO $ putStrLn e >> exitFailure
Right a -> run (f a) nonOpts opts
, nonOptions = nonOptions (f undefined)
, options = ((identify names,names),optDescr) : options (f undefined)
, ignoringOptions = ignoringOptions (f undefined)
}
ignoreOption :: Option a -> Action m -> Action m
ignoreOption (Option _ g _ _) a = a
{
ignoringOptions = g : ignoringOptions a
}