diff --git a/Examples/Full.hs b/Examples/Full.hs new file mode 100644 --- /dev/null +++ b/Examples/Full.hs @@ -0,0 +1,61 @@ +module Full where + + +-- The example of using System.Console.Options. +import Options + +-- Used modules from the console-program package. +import System.Console.Command (Commands,Command(..),execute,showUsage) +import qualified System.Console.Action as Action +import qualified System.Console.Argument as Argument + +-- Standard tree type, used to build the tree of commands. +import Data.Tree (Tree(Node)) + + +main :: IO () +main = execute defaults myCommands + +myCommands :: Commands MyConfig +myCommands = Node + (Command "count" [] [] "A program for counting" . Action.simple $ putStrLn "No command given; try \"count help\".") + [ + Node countUp [] + , Node countDown [] + , Node help [] + ] + +countUp,countDown,help :: Command MyConfig +countUp = Command + { + name = "up" + , applicableNonOptions = [] + , applicableOptions = [verboseOpt] + , description = "Count up" + , action = Action.usingConfiguration $ \ myConfig -> Action.simple $ if verbosity_ myConfig == Quiet + then putStrLn "Counting quietly!" + else mapM_ print [1 ..] + } +countDown = Command + { + name = "down" + , description = "Count down from INT." + , applicableNonOptions = ["INT"] + , applicableOptions = [] + , action = Action.withArgument Argument.natural $ \ upperBound -> Action.simple $ mapM_ print [upperBound, pred upperBound .. 1] + } +help = Command "help" [] [] "Show usage info" $ Action.simple (showUsage myCommands) + +verboseOpt = Argument.option Verbosity ['v'] ["verbose" ] verbosity "Specify the verbosity of the program; " + +verbosity :: Argument.Type Verbosity +verbosity = Argument.Type + { + Argument.parser = \ x -> case x of + "verbose" -> Right Verbose + "normal" -> Right Normal + "quiet" -> Right Quiet + s -> Left $ "The argument " ++ show s ++ " could not be recognised as a verbosity." + , Argument.name = "verbosity" + , Argument.defaultValue = Just Verbose + } diff --git a/Examples/Options.hs b/Examples/Options.hs new file mode 100644 --- /dev/null +++ b/Examples/Options.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell,TypeFamilies,StandaloneDeriving #-} +module Options where + + +import qualified System.Console.Options as Options + + +data Verbosity + = Quiet + | Normal + | Verbose + deriving (Show,Eq) + +-- This is an example use of the Options.create Template Haskell function. +-- To see what datatypes this generates, load this module in GHCi and type +-- ":browse". +$( + Options.create "MyConfig" "MySetting" + [ + ("foo" ,Options.ConT ''Integer ) + , ("bar" ,Options.ConT ''Bool ) + , ("verbosity",Options.ConT ''Verbosity) + ] + ) + +deriving instance Show MyConfig + +defaults :: MyConfig +defaults = MyConfig + { + verbosity_ = Normal + , foo_ = 42 + , bar_ = True + } diff --git a/Examples/Simple.hs b/Examples/Simple.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple.hs @@ -0,0 +1,23 @@ +module Simple where + + +import Data.Tree (Tree(Node)) + +import System.Console.Command (Commands,Command(..),execute) +import System.Console.Action (simple) + + +myCommands :: Commands () -- We need no configuration, so we use '()'. +myCommands = Node + (Command "say" [] [] "" . simple $ putStrLn "No command given.") + [ + Node + (Command "yes" [] [] "" . simple $ putStrLn "Yes!") + [] + , Node + (Command "no" [] [] "" . simple $ putStrLn "No!") + [] + ] + +main :: IO () +main = execute () myCommands 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.1.0.2 +Version: 0.2.0.0 Cabal-Version: >= 1.6 License: BSD3 Author: Arie Peterson @@ -25,6 +25,10 @@ - it parses a configuration file, in addition to the command line arguments. Category: System Build-Type: Simple +Extra-Source-Files: + Examples/Simple.hs + Examples/Options.hs + Examples/Full.hs Source-repository head Type: darcs @@ -33,7 +37,6 @@ Library Build-Depends: base == 4.*, - transformers == 0.2.*, containers >= 0.1 && < 0.4, directory == 1.0.*, utf8-string >= 0.3.5 && < 0.4, @@ -47,4 +50,6 @@ System.Console.Action, System.Console.Argument, System.Console.Options + Other-Modules: + System.Console.Action.Internal Hs-Source-Dirs: src diff --git a/src/System/Console/Action.hs b/src/System/Console/Action.hs --- a/src/System/Console/Action.hs +++ b/src/System/Console/Action.hs @@ -1,38 +1,11 @@ module System.Console.Action ( Action - , run - , readerT , simple , withArgument + , usingConfiguration ) where -import qualified System.Console.Argument as Argument - -import qualified Control.Monad.Trans.Reader as Reader -import System.Exit (exitFailure) - - -data Action o - = Action { run :: [String] -> o -> IO () } - -readerT :: Reader.ReaderT o IO () -> Action o -readerT f = Action (const $ Reader.runReaderT f) - --- | A simple action, taking no argument. -simple :: IO () -> Action o -simple = Action . const . const - --- | Create an action that takes an argument (non-option). --- --- The type of argument is specified by the first parameter; these values can --- be obtained from the module "System.Console.Argument". -withArgument :: Argument.Type x -> (x -> Action o) -> Action o -withArgument at f = Action g where - g (x : xs) = either - (const . (>> exitFailure) . putStrLn) -- Show errors and exit. - (\ y -> run (f y) xs) -- Argument parsing succeeded; run the action. - (Argument.parser at (Argument.name at) x) - g [] = const $ putStrLn $ "Error: missing argument of type " ++ Argument.name at +import System.Console.Action.Internal diff --git a/src/System/Console/Action/Internal.hs b/src/System/Console/Action/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Action/Internal.hs @@ -0,0 +1,45 @@ +module System.Console.Action.Internal + ( + Action + , run + + , simple + , withArgument + , usingConfiguration + ) where + + +import qualified System.Console.Argument as Argument + +import System.Exit (exitFailure) + + +-- | An @Action s@ is an @IO@ action, which may take arguments +-- (\"non-options\") from the command line, and which may use settings +-- of type @s@. +data Action s + = Action + { + run :: [String] -> s -> IO () + } + +-- | A simple action, taking no argument. +simple :: IO () -> Action s +simple = Action . const . const + +-- | 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". +withArgument :: Argument.Type x -> (x -> Action s) -> Action s +withArgument at f = Action g where + g (x : xs) = either + (const . (>> exitFailure) . putStrLn) -- Show errors and exit. + (\ y -> run (f y) xs) -- Argument parsing succeeded; run the action. + (Argument.parser at x) + g [] = const $ putStrLn ("Error: missing argument of type " ++ Argument.name at) >> exitFailure + + -- | Create an action that depends on the program configuration (determined + -- by the configuration file and command line arguments). +usingConfiguration :: (s -> Action s) -> Action s +usingConfiguration f = Action (\ nonOptions settings -> run (f settings) nonOptions settings) diff --git a/src/System/Console/Argument.hs b/src/System/Console/Argument.hs --- a/src/System/Console/Argument.hs +++ b/src/System/Console/Argument.hs @@ -24,16 +24,17 @@ import qualified Text.Parsec.Extra as P + -- | A @Type a@ represents the type of an option or argument. data Type a = Type { - parser :: String -> String -> Either String a + parser :: String -> Either String a , name :: String , defaultValue :: Maybe a } instance Functor Type where - fmap f t = t { parser = ((.) . (.)) (fmap f) (parser t), defaultValue = fmap f (defaultValue t) } + fmap f t = t { parser = fmap f . parser t, defaultValue = fmap f (defaultValue t) } -- | Create an option description. option @@ -44,8 +45,8 @@ -> String -- ^ Description. -> GetOpt.OptDescr (Either String s) -- ^ The resulting option description. option inj short long t description = case defaultValue t of - Nothing -> GetOpt.Option short long (GetOpt.ReqArg (fmap inj . parser t (name t)) (name t)) description - Just a -> GetOpt.Option short long (GetOpt.OptArg (maybe (Right $ inj a) $ fmap inj . parser t (name t)) (name t)) description + Nothing -> GetOpt.Option short long (GetOpt.ReqArg ( fmap inj . parser t) (name t)) description + Just a -> GetOpt.Option short long (GetOpt.OptArg (maybe (Right $ inj a) $ fmap inj . parser t) (name t)) description -- Argument types. @@ -57,14 +58,14 @@ -- | A plain string. string :: Type String -string = Type (const Right) "STRING" Nothing +string = Type Right "STRING" Nothing -- | A boolean. Argument can be \"1\",\"0\",\"true\",\"false\",\"on\",\"off\". boolean :: Type Bool boolean = Type { name = "BOOL" - , parser = \ _ y -> maybe (e y) Right . flip Map.lookup m . map toLower $ y + , parser = \ y -> maybe (e y) Right . flip Map.lookup m . map toLower $ y , defaultValue = Just True } where @@ -73,15 +74,15 @@ -- | A natural number (in decimal). natural :: Type Integer -natural = Type { name = "INT (natural)", parser = const (P.parseM P.natural ""), defaultValue = Nothing } +natural = Type { name = "INT (natural)", parser = P.parseM P.natural "", defaultValue = Nothing } -- | An integer number (in decimal). integer :: Type Integer -integer = Type { name = "INT", parser = const (P.parseM P.integer ""), defaultValue = Nothing } +integer = Type { name = "INT", parser = P.parseM P.integer "", defaultValue = Nothing } -- | A directory path. A trailing slash is stripped, if present. directory :: Type FilePath -directory = Type { name = "DIR", parser = const (Right . stripTrailingSlash), defaultValue = Nothing } +directory = Type { name = "DIR", parser = Right . stripTrailingSlash, defaultValue = Nothing } where stripTrailingSlash x = case viewR x of Nothing -> "" 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 @@ -2,14 +2,18 @@ ( Commands , Command (Command,name,applicableNonOptions,applicableOptions,description,action) - - , single + + -- * Using a command tree to construct a program + , execute , showUsage + + -- * Configuration file + -- $doc ) where -import qualified System.Console.Action as Action -import qualified System.Console.Options as Options +import qualified System.Console.Action.Internal as Action +import qualified System.Console.Options as Options import Control.Applicative ((<$>)) import Control.Arrow ((&&&),second) @@ -34,19 +38,32 @@ type Commands setting = Tree.Tree (Command setting) --- | A @Command s@ is an action, together with some descriptive information: --- name (this is the textual command that invokes the action), description, --- and lists of applicable options and non-options. @s@ is the type of setting. -data Command s +-- | A @Command s@ is an action, together with some descriptive information. +-- The description, and lists of applicable options and non-options are +-- used only to show usage information for the command. +-- @s@ is the type of settings that the action may use. +data Command c = Command { - name :: String - , applicableNonOptions :: [String] - , applicableOptions :: [GetOpt.OptDescr (Either String s)] - , description :: String - , action :: Action.Action (Options.Options s) + name :: String -- ^ This determines which command is executed, depending on the command line. + , applicableNonOptions :: [String] -- ^ For usage info. + , applicableOptions :: [GetOpt.OptDescr (Either String (Options.Setting c))] -- ^ For usage info. The union of this field, over all commands in the command tree, also determines which options will be recognised. + , description :: String -- ^ For usage info. + , action :: Action.Action c } +-- $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 command at the +-- root of the command tree (usually the name of the program). +-- +-- Settings in this file are of the form +-- @ +-- option-name=option-value +-- @ +-- , see module "Fez.Data.Conf" for details. The format of the \"option-value\" +-- part depends on the type of the option argument; see "System.Console.Argument". + fromDisk :: String -> IO [String] fromDisk configFile = do home <- getHomeDirectory @@ -55,7 +72,7 @@ -- Load configuration file and parse the command line into settings -- and non-options. -load :: Commands s -> IO ([String],[s]) +load :: Commands c -> IO ([String],[Options.Setting c]) load commands = do let options = Set.toList $ collectOptions commands fileArgs <- fromDisk $ '.' : name (Tree.rootLabel commands) @@ -65,18 +82,25 @@ else traverse putStrLn errors >> showUsage commands >> exitFailure -- | Load the configuration file (if present), and run the action given on the command line. -single :: (Options.Setting s) => Options.Options s -> Commands s -> IO () -single defaults commands = uncurry (select commands) . second (flip Options.apply defaults) =<< load commands +-- You may use this function, with appropriate arguments, as your @main@ function. +-- +-- Settings in the configuration file override the default configuration; +-- settings on the command line override both. +execute :: (Options.Configuration c) => + c -- ^ Default configuration. + -> Commands c -- ^ Tree of commands. + -> IO () +execute defaults commands = uncurry (select commands) . second (flip Options.apply defaults) =<< load commands -- Select the right command from the command tree, given a list of non-options, and the options. -select :: (Options.Setting s) => Commands s -> [String] -> Options.Options s -> IO () +select :: (Options.Configuration c) => Commands c -> [String] -> c -> IO () select (Tree.Node root _ ) [] = Action.run (action root) [] select (Tree.Node root forest) nos@(x : xs) = case lookup x $ map (name . Tree.rootLabel &&& id) forest of Nothing -> Action.run (action root) nos Just cs -> select cs xs --- | Show usage info for the program. -showUsage :: Commands o -> IO () +-- | Print usage info for the program to stdout. +showUsage :: Commands c -> IO () showUsage = PP.putDoc . usage where usage (Tree.Node c ns) = subcs ns . (PP.<> PP.line) . opts c . descr c . nonOpts c $ PP.bold (PP.text $ name c) @@ -96,7 +120,7 @@ list i p a = PP.fill i . PP.cat . PP.punctuate PP.comma . map (\ x -> PP.text p PP.<> PP.text x PP.<> a) subcs ns = if null ns then id else flip (PP.<$>) $ PP.indent 2 (PP.vsep $ map usage ns) -collectOptions :: Commands o -> Set.Set (GetOpt.OptDescr (Either String o)) +collectOptions :: Commands c -> Set.Set (GetOpt.OptDescr (Either String (Options.Setting c))) collectOptions = foldMap (Set.fromList . applicableOptions) instance Eq (GetOpt.OptDescr a) where diff --git a/src/System/Console/Options.hs b/src/System/Console/Options.hs --- a/src/System/Console/Options.hs +++ b/src/System/Console/Options.hs @@ -1,8 +1,14 @@ {-# LANGUAGE TypeFamilies,TemplateHaskell,ScopedTypeVariables #-} +-- | This module defines a class for dealing with configurations and settings. +-- It also exports a Template Haskell function to easily create datatypes +-- to deal with the configuration of your program. +-- +-- For an example using this module, see the file \"Examples/Options.hs\" in +-- the package tarball. module System.Console.Options ( - Options - , Setting(set) + Configuration(set) + , Setting , apply , create @@ -16,46 +22,45 @@ import Language.Haskell.TH --- | An instance @s@ of 'Setting' has as values /partial/ sets of option assignments, --- as given by the user in a configuration file or command line options. --- @'Options' s@ is the associated type of complete configurations, as the --- program peruses. -class Setting s where - type Options s - set :: s -> Options s -> Options s +-- | An instance @c@ of 'Configuration' has as values complete configurations, +-- as the program peruses. @'Setting' s@ is the associated type of a single +-- setting, or option assignments, as given by the user in a configuration +-- file or command line options. +class Configuration c where + type Setting c + set :: Setting c -> c -> c --- Necessary to avoid TH staging error. -setName = 'set +instance Configuration () where + type Setting () = () + set _ _ = () -apply :: forall s. (Setting s) => [s] -> Options s -> Options s +apply :: forall c. (Configuration c) => [Setting c] -> c -> c apply = flip (foldl' (flip set)) -{- -instance Setting (Endo a) where - type Options (Endo a) = a - set (Endo f) = f --} +-- Necessary to avoid TH staging error. +setName = 'set --- | 'create' is a template haskell computation. Given names for the \"options\" --- type, the \"settings\" type and the \"set\" function, and a list of settings --- (pairs of their names and types), it creates those datatypes and function, --- and an instance of the 'Settings' class. -create :: String -> String -> String -> [(String,Type)] -> Q [Dec] -create optionsName settingName set settings = do +-- | 'create' is a template haskell computation. Given names for the +-- \"configuration\" type and the \"settings\" type, and a list of settings +-- (pairs of their names and types), it creates those datatypes, and an +-- instance of the 'Configuration' class. +create :: String -> String -> [(String,Type)] -> Q [Dec] +create configurationName settingName settings = do x <- newName "x" y <- newName "y" - let optionType = DataD [] (mkName optionsName) [] [RecC (mkName optionsName) $ flip map settings $ \ (n,t) -> (mkName $ n ++ "_",NotStrict,t)] [] + s <- newName "set" + let configurationType = DataD [] (mkName configurationName) [] [RecC (mkName configurationName) $ flip map settings $ \ (n,t) -> (mkName $ n ++ "_",NotStrict,t)] [] let settingType = DataD [] (mkName settingName) [] (flip map settings $ \ (n,t) -> NormalC (mkName $ capitalise n) [(NotStrict,t)]) [] - let setFunction = FunD (mkName set) $ flip map settings $ \ (n,_) -> Clause + let setFunction = FunD s $ flip map settings $ \ (n,_) -> Clause [ConP (mkName $ capitalise n) [VarP x],VarP y] (NormalB $ RecUpdE (VarE y) [(mkName $ n ++ "_",VarE x)] ) [] - let settingsInstance = InstanceD [] (ConT ''Setting `AppT` ConT (mkName settingName)) + let configurationInstance = InstanceD [] (ConT ''Configuration `AppT` ConT (mkName configurationName)) [ - TySynInstD ''Options [ConT $ mkName settingName] (ConT $ mkName optionsName) - , FunD setName [Clause [] (NormalB $ VarE $ mkName set) []] + TySynInstD ''Setting [ConT $ mkName configurationName] (ConT $ mkName settingName) + , FunD setName [Clause [] (NormalB $ VarE s) []] ] - return $ optionType : settingType : setFunction : settingsInstance : [] + return $ configurationType : settingType : setFunction : configurationInstance : [] where capitalise :: String -> String capitalise [] = []