diff --git a/Examples/Full.hs b/Examples/Full.hs --- a/Examples/Full.hs +++ b/Examples/Full.hs @@ -12,7 +12,7 @@ main :: IO () main = single myCommands -myCommands :: Commands +myCommands :: Commands IO myCommands = Node (Command "count" "A program for counting" . io $ putStrLn "No command given; try \"count help\".") [ @@ -21,7 +21,7 @@ , Node help [] ] -countUp,countDown,help :: Command +countUp,countDown,help :: Command IO countUp = Command { name = "up" diff --git a/Examples/Simple.hs b/Examples/Simple.hs --- a/Examples/Simple.hs +++ b/Examples/Simple.hs @@ -5,7 +5,7 @@ import System.Console.Program (single) -myCommands :: Commands +myCommands :: Commands IO myCommands = Node (Command "say" "" . io $ putStrLn "No command given.") [ diff --git a/console-program.cabal b/console-program.cabal --- a/console-program.cabal +++ b/console-program.cabal @@ -1,5 +1,5 @@ Name: console-program -Version: 0.3.1.4 +Version: 0.3.2.0 Cabal-Version: >= 1.6 License: BSD3 Author: Arie Peterson diff --git a/src/System/Console/Command.hs b/src/System/Console/Command.hs --- a/src/System/Console/Command.hs +++ b/src/System/Console/Command.hs @@ -29,41 +29,44 @@ ) import qualified System.Console.Argument as Argument +import Control.Monad.IO.Class (MonadIO,liftIO) import qualified Data.Map as Map import qualified Data.Tree as Tree -import System.Exit (exitFailure) +import System.Exit (exitFailure) --- | @Commands s@ is a tree of commands. It represents the whole set of --- possible commands of a program. -type Commands - = Tree.Tree Command +-- | @Commands m@ is a tree of commands (with action in the monad @m@). +-- It represents the whole set of possible commands of a program. +type Commands m + = Tree.Tree (Command m) -- | A simple action, taking no argument, and having no options. -io :: IO () -> Action +io :: (MonadIO m) => m () -> Action m io h = Action r [] [] [] where r [] _ = h - r rest _ = putStrLn e >> exitFailure where + r rest _ = liftIO $ putStrLn e >> exitFailure where e = "Error: unused non-option or unrecognised command: " ++ unwords rest -- | Create an action that takes an argument (non-option). -- -- The type of argument is specified by the first parameter; such values can -- be obtained from the module "System.Console.Argument". -withNonOption :: Argument.Type x -> (x -> Action) -> Action -withNonOption at f = Action +withNonOption :: (MonadIO m) => Argument.Type x -> (x -> Action m) -> Action m +withNonOption argumentType f = Action { run = \ nonOpts opts -> case nonOpts of - (x : xs) -> either - ((>> exitFailure) . putStrLn) -- Show errors and exit. - (\ y -> run (f y) xs opts) -- Argument parsing succeeded; run the action. - (Argument.parser at x) - [] -> maybe - (putStrLn ("Error: missing argument of type " ++ Argument.name at) >> exitFailure) - (\ y -> run (f y) [] opts) - (Argument.defaultValue at) - , nonOptions = Argument.name at : nonOptions (f undefined) + (x : xs) -> case Argument.parser argumentType x of + Left e -> liftIO $ do -- Show errors and exit. + putStrLn e + exitFailure + Right y -> run (f y) xs opts -- Argument parsing succeeded; run the action. + [] -> 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) } @@ -72,11 +75,11 @@ -- -- The first parameter is a description of the option; such a value can be -- constructed using 'System.Console.Argument.option'. -withOption :: Option a -> (a -> Action) -> Action +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 -> putStrLn e >> exitFailure + Left e -> liftIO $ putStrLn e >> exitFailure Right a -> run (f a) nonOpts opts , nonOptions = nonOptions (f undefined) , options = optDescr : options (f undefined) @@ -88,7 +91,7 @@ -- This is especially useful if this option is given in the configuration -- file, but is meant for other commands; then this action will not give an -- error message about an unrecognised option. -ignoreOption :: Option a -> Action -> Action +ignoreOption :: Option a -> Action m -> Action m ignoreOption (Option _ g _ _) a = a { ignoringOptions = g : ignoringOptions a diff --git a/src/System/Console/ConfigFile.hs b/src/System/Console/ConfigFile.hs --- a/src/System/Console/ConfigFile.hs +++ b/src/System/Console/ConfigFile.hs @@ -7,24 +7,25 @@ import System.Console.Command import System.Console.Internal (name) -import Control.Applicative ((<$>)) -import Control.Exception (tryJust) -import Control.Monad (guard) -import Data.List (isPrefixOf,concat) -import Data.List.Split (Splitter,split,whenElt,keepDelimsR) +import Control.Applicative ((<$>)) +import Control.Exception (tryJust) +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO,liftIO) +import Data.List (isPrefixOf,concat) +import Data.List.Split (Splitter,split,whenElt,keepDelimsR) import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe (isJust) +import Data.Map (Map) +import Data.Maybe (isJust) import qualified Data.Tree as Tree import qualified Fez.Data.Conf as Fez -import System.Directory (getAppUserDataDirectory) -import System.IO.Error (isDoesNotExistError) +import System.Directory (getAppUserDataDirectory) +import System.IO.Error (isDoesNotExistError) type UserCommand = [String] -readFromFile :: Commands -> UserCommand -> IO [String] -readFromFile commands command = do +readFromFile :: (MonadIO m) => Commands m -> UserCommand -> m [String] +readFromFile commands command = liftIO $ do dataDir <- getAppUserDataDirectory $ name (Tree.rootLabel commands) let configFile = dataDir ++ "/" ++ "config" fileContents <- either (const "") id <$> tryJust (guard . isDoesNotExistError) (readFile configFile) diff --git a/src/System/Console/Internal.hs b/src/System/Console/Internal.hs --- a/src/System/Console/Internal.hs +++ b/src/System/Console/Internal.hs @@ -5,12 +5,12 @@ import qualified System.Console.GetOpt as GetOpt --- | An @Action@ is an @IO@ action, which may take arguments +-- | An @Action m@ is an action (in the monad @m@), which may take arguments -- (\"non-options\") and options from the command line. -data Action +data Action m = Action { - run :: [String] -> Map Identifier (Maybe String) -> IO () + run :: [String] -> Map Identifier (Maybe String) -> m () , nonOptions :: [String] , options :: [GetOpt.OptDescr (Identifier,Maybe String)] , ignoringOptions :: [GetOpt.OptDescr (Identifier,Maybe String)] @@ -28,8 +28,9 @@ (Maybe String -> Either String a) --- | A @Command@ is an action, together with some descriptive information. -data Command +-- | A @Command m@ is an action (in the monad @m@), together with some +-- descriptive information. +data Command m = Command { -- | This determines which command is executed. @@ -37,5 +38,5 @@ -- | For usage info. , description :: String -- | The actual action performed by this command. - , action :: Action + , action :: Action m } diff --git a/src/System/Console/Program.hs b/src/System/Console/Program.hs --- a/src/System/Console/Program.hs +++ b/src/System/Console/Program.hs @@ -20,9 +20,10 @@ import System.Console.ConfigFile (readFromFile) import System.Console.Internal (run,options,nonOptions,ignoringOptions,action,description,name) -import Control.Applicative ((<|>),(*>)) +import Control.Applicative (Applicative,(<|>),(*>)) import Control.Arrow ((&&&),second) import Control.Monad (when,void) +import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Trans.Class (lift) import qualified Data.Map as Map import Data.Traversable (traverse) @@ -39,7 +40,7 @@ -- $configfile -- The configuration file is assumed to be in the user's home directory, and --- to be named \".foobar\", where \"foobar\" is the name of the +-- to be named \".foobar/config\", where \"foobar\" is the name of the -- root of the command tree (usually the name of the program). -- -- Settings in this file are of the form @@ -59,7 +60,7 @@ -- Parse the given list of strings into a command, non-options and options. -parse :: Commands -> [String] -> IO () +parse :: (MonadIO m,Applicative m) => Commands m -> [String] -> m () parse commands args = do let (commandString,command,restArgs) = select commands args fileArgs <- readFromFile commands commandString @@ -68,11 +69,11 @@ (options (action command) ++ ignoringOptions (action command)) (fileArgs ++ restArgs) when (not $ null errors) . void $ - traverse putStrLn errors + traverse (liftIO . putStrLn) errors run (action command) nonOpts $ Map.fromList opts -- Select the right command from the command tree, and return the rest of the command line. -select :: Commands -> [String] -> ([String],Command,[String]) +select :: Commands m -> [String] -> ([String],Command m,[String]) select (Tree.Node root _ ) [] = ([],root,[]) select (Tree.Node root subs) (x : xs) = case lookup x $ map (name . Tree.rootLabel &&& id) subs of Nothing -> ([],root,x : xs) @@ -82,23 +83,24 @@ -- the command line. Settings on the command line override the configuration -- file. -- --- You may use this function, applied to your tree of available commands, as your @main@ function. -single :: Commands -> IO () -single commands = parse commands =<< getArgs +-- You may use this function, applied to your tree of available commands, +-- as your @main@ function. +single :: (MonadIO m,Applicative m) => Commands m -> m () +single commands = parse commands =<< liftIO getArgs -- | Start an interactive session. Arguments to the program are ignored; -- instead, the user may repeatedly enter a command, possibly with options, -- which will be executed. -interactive :: Commands -> IO () +interactive :: (MonadIO m,Haskeline.MonadException m,Applicative m) => Commands m -> m () interactive commands = do Haskeline.runInputT Haskeline.defaultSettings $ sequence_ . repeat $ one where one = getLine' >>= \ line -> case words' line of - Left e -> lift $ putStrLn e + Left e -> liftIO $ putStrLn e Right ws -> lift $ parse commands ws getLine' = do - lift . putStrBold $ name (Tree.rootLabel commands) - maybe (lift exitSuccess) return =<< Haskeline.getInputLine ": " + putStrBold $ name (Tree.rootLabel commands) + maybe (liftIO exitSuccess) return =<< Haskeline.getInputLine ": " words' :: String -> Either String [String] words' = either (Left . show) Right . P.parse p "" where @@ -111,15 +113,15 @@ escape = P.char '\\' escaped x = escape *> x -putStrBold :: String -> IO () -putStrBold x = do +putStrBold :: (MonadIO m) => String -> m () +putStrBold x = liftIO $ do ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity] putStr x ANSI.setSGR [ANSI.Reset] -- | Print usage info for the program to stdout. -showUsage :: Commands -> IO () -showUsage = PP.putDoc . usage +showUsage :: (MonadIO m) => Commands n -> m () +showUsage = liftIO . PP.putDoc . usage where usage (Tree.Node c ns) = (PP.<> PP.line) . subcs ns . (PP.<> PP.line) . opts c . descr c . nonOpts c $ PP.bold (PP.text $ name c) descr c = flip (PP.<$>) $ PP.string (description c)