diff --git a/Examples/Full.hs b/Examples/Full.hs --- a/Examples/Full.hs +++ b/Examples/Full.hs @@ -1,12 +1,8 @@ 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 System.Console.Command (Commands,Tree(Node),Command(..),execute,showUsage,io) import qualified System.Console.Argument as Argument -- Standard tree type, used to build the tree of commands. @@ -16,23 +12,21 @@ main :: IO () main = execute defaults myCommands -myCommands :: Commands MyConfig +myCommands :: Commands myCommands = Node - (Command "count" [] [] "A program for counting" . Action.simple $ putStrLn "No command given; try \"count help\".") + (Command "count" "A program for counting" . io $ putStrLn "No command given; try \"count help\".") [ Node countUp [] , Node countDown [] , Node help [] ] -countUp,countDown,help :: Command MyConfig +countUp,countDown,help :: Command countUp = Command { - name = "up" - , applicableNonOptions = [] - , applicableOptions = [verboseOpt] - , description = "Count up" - , action = Action.usingConfiguration $ \ myConfig -> Action.simple $ if verbosity_ myConfig == Quiet + name = "up" + , description = "Count up" + , action = withOption verboseOpt $ \ v -> io $ if v == Quiet then putStrLn "Counting quietly!" else mapM_ print [1 ..] } @@ -40,13 +34,12 @@ { name = "down" , description = "Count down from INT." - , applicableNonOptions = ["INT"] - , applicableOptions = [] - , action = Action.withArgument Argument.natural $ \ upperBound -> Action.simple $ mapM_ print [upperBound, pred upperBound .. 1] + , action = withNonOption Argument.natural $ \ upperBound -> io $ mapM_ print [upperBound, pred upperBound .. 1] } -help = Command "help" [] [] "Show usage info" $ Action.simple (showUsage myCommands) +help = Command "help" "Show usage info" $ io (showUsage myCommands) -verboseOpt = Argument.option Verbosity ['v'] ["verbose" ] verbosity "Specify the verbosity of the program; " +verboseOpt :: Option +verboseOpt = Argument.option Verbosity ['v'] ["verbose" ] verbosity "Specify the verbosity of the program; " verbosity :: Argument.Type Verbosity verbosity = Argument.Type diff --git a/Examples/Options.hs b/Examples/Options.hs deleted file mode 100644 --- a/Examples/Options.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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 --- a/Examples/Simple.hs +++ b/Examples/Simple.hs @@ -1,23 +1,21 @@ module Simple where -import Data.Tree (Tree(Node)) - -import System.Console.Command (Commands,Command(..),execute) -import System.Console.Action (simple) +import System.Console.Command (Commands,Tree(Node),Command(..),io) +import System.Program (single) -myCommands :: Commands () -- We need no configuration, so we use '()'. +myCommands :: Commands myCommands = Node - (Command "say" [] [] "" . simple $ putStrLn "No command given.") + (Command "say" "" . io $ putStrLn "No command given.") [ Node - (Command "yes" [] [] "" . simple $ putStrLn "Yes!") + (Command "yes" "" . io $ putStrLn "Yes!") [] , Node - (Command "no" [] [] "" . simple $ putStrLn "No!") + (Command "no" "" . io $ putStrLn "No!") [] ] main :: IO () -main = execute () myCommands +main = single myCommands diff --git a/console-program.cabal b/console-program.cabal --- a/console-program.cabal +++ b/console-program.cabal @@ -1,11 +1,11 @@ Name: console-program -Version: 0.2.0.1 +Version: 0.3.0.0 Cabal-Version: >= 1.6 License: BSD3 Author: Arie Peterson Maintainer: ariep@xs4all.nl Category: Console -Synopsis: Interprets the command line and a config file as commands and options +Synopsis: Interprets command line arguments and the contents of a config file as commands and options Description: This library provides an infrastructure to build command line programs. It provides the following features: . @@ -16,8 +16,11 @@ - collect options and actions from a configuration file and the command line, and execute the proper action. . . - It provides functionality similar to the \"cmdargs\" package. Main differences: + Examples of using this library may be found in the "Examples" directory in the package tarball. . + . + It provides functionality similar to the cmdargs package. Main differences: + . - console-program does not use unsafePerformIO, and tries to give a more haskellish, referentially transparent interface; . - it allows a full tree of \"modes\", instead of a list, so a command can have subcommands; @@ -27,7 +30,6 @@ Build-Type: Simple Extra-Source-Files: Examples/Simple.hs - Examples/Options.hs Examples/Full.hs Source-repository head @@ -37,19 +39,22 @@ Library Build-Depends: base == 4.*, - containers >= 0.1 && < 0.4, - directory == 1.0.*, - utf8-string >= 0.3.5 && < 0.4, + containers >= 0.1 && < 0.6, + directory >= 1.0 && < 1.2, fez-conf == 1.0.*, - template-haskell, - ansi-wl-pprint == 0.5.*, - utility-ht == 0.0.5.*, + ansi-wl-pprint >= 0.5 && < 0.7, + ansi-terminal == 0.5.*, + haskeline == 0.7.*, + transformers >= 0.2 && < 0.4, + utility-ht == 0.0.*, + split == 0.2.*, + parsec == 3.1.*, parsec-extra == 0.1.* Exposed-Modules: - System.Console.Command, - System.Console.Action, System.Console.Argument, - System.Console.Options + System.Console.Command, + System.Console.Program Other-Modules: - System.Console.Action.Internal + System.Console.ConfigFile, + System.Console.Internal Hs-Source-Dirs: src diff --git a/src/System/Console/Action.hs b/src/System/Console/Action.hs deleted file mode 100644 --- a/src/System/Console/Action.hs +++ /dev/null @@ -1,11 +0,0 @@ -module System.Console.Action - ( - Action - - , simple - , withArgument - , usingConfiguration - ) where - - -import System.Console.Action.Internal diff --git a/src/System/Console/Action/Internal.hs b/src/System/Console/Action/Internal.hs deleted file mode 100644 --- a/src/System/Console/Action/Internal.hs +++ /dev/null @@ -1,45 +0,0 @@ -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 a configuration --- of type @s@. -data Action c - = Action - { - run :: [String] -> c -> IO () - } - --- | A simple action, taking no argument. -simple :: IO () -> Action c -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 c) -> Action c -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 :: (c -> Action c) -> Action c -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 @@ -13,12 +13,15 @@ , integer -- * Option descriptions + , Option , option ) where -import Data.Char (toLower) -import Data.List.HT (viewR) +import System.Console.Internal (Option(Option),Identifier(Short,Long)) + +import Data.Char (toLower) +import Data.List.HT (viewR) import qualified Data.Map as Map import qualified System.Console.GetOpt as GetOpt import qualified Text.Parsec.Extra as P @@ -48,20 +51,34 @@ instance Functor Type where fmap f t = t { parser = fmap f . parser t, defaultValue = fmap f (defaultValue t) } --- | Create an option description. You need this to describe the options your --- command uses; see 'System.Console.Command.Command'. +-- | Create an option description. +-- +-- Options can have arguments, as in @myprogram --foo=bar@, where @bar@ +-- is the argument to @foo@. These arguments have types, dictated by the +-- particular option; this type is the third parameter to @option@. option - :: (a -> s) -- ^ Function that creates a setting (of type @s@) from the option argument. - -> [Char] -- ^ List of short option characters. - -> [String] -- ^ List of long option strings. - -> Type a -- ^ Type of option argument. - -> 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)) description - Just a -> GetOpt.Option short long (GetOpt.OptArg (maybe (Right $ inj a) $ fmap inj . parser t) (name t)) description + :: [Char] -- ^ List of short option characters. + -> [String] -- ^ List of long option strings. + -> Type a -- ^ Type of option argument. + -> a -- ^ Default value. + -> String -- ^ Description. + -> Option a -- ^ The resulting option description. +option short long t def description = let + identifier = if null short then Long (head long) else Short (head short) + in Option + identifier + (GetOpt.Option + short + long + (maybe + (GetOpt.ReqArg ((,) identifier . Just) $ name t) + (const $ GetOpt.OptArg ((,) identifier) $ name t) + (defaultValue t)) + description) + def + (maybe (maybe (Left "Option argument missing.") Right $ defaultValue t) (parser t)) --- Argument types. +-- Common argument types. optional :: a -- ^ Default value. @@ -73,7 +90,7 @@ string :: Type String string = Type Right "STRING" Nothing --- | A boolean. Argument can be \"1\",\"0\",\"true\",\"false\",\"on\",\"off\". +-- | A boolean. Argument can be \"1\",\"0\",\"true\",\"false\",\"on\",\"off\",\"yes\",\"no\". boolean :: Type Bool boolean = Type { @@ -82,7 +99,7 @@ , defaultValue = Just True } where - m = Map.fromList [("1",True),("0",False),("true",True),("false",False),("on",True),("off",False)] + m = Map.fromList [("1",True),("0",False),("true",True),("false",False),("on",True),("off",False),("yes",True),("no",False)] e y = Left $ "Argument " ++ show y ++ " could not be recognised as a boolean." -- | A natural number (in decimal). 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 @@ -1,159 +1,84 @@ --- | This is the main module of console-program. You can use it to build a --- console program, that parses the command line (and a configuration file), --- divides it into modes/commands, options and non-options, and executes the --- corresponding action from a tree of commands. --- --- The main function is 'execute'; provided with a tree of commands and a --- default configuration, it can be used as the @main@ function. --- +-- | -- A \"mode\" or \"command\" provides a mode of operation of your program. --- This allows a single executable to provide many different pieces of +-- This allows a single program to provide many different pieces of -- functionality. The first argument to the program (or the first few, if it -- has subcommands) determines which command should be executed. -- (@darcs@ and @cabal@ are examples of programs that make heavy use of modes.) -- --- Options can be given in a configuration file, and on the command line. --- Commands specify which options apply to them (the 'applicableOptions' field). --- Such option descriptions can be created by 'System.Console.Argument.option'. --- --- Options can have arguments, as in @program --option=value@, where @value@ is --- the argument to @option@. These arguments have types, dictated by the --- particular option. These types are represented by a 'System.Console.Argument.Type'. +-- An 'Action' represents an IO action, together with information about +-- applicable option and non-option arguments. -- -- A command can have also non-option arguments (plain arguments). These also -- have types. Create such commands using the function 'System.Console.Action.withArgument'. module System.Console.Command ( - Commands - , Command (Command,name,applicableNonOptions,applicableOptions,description,action) - - -- * Using a command tree to construct a program - , execute - , showUsage + Commands,Tree.Tree(Tree.Node) + , Command - -- * Configuration file - -- $configfile + , Action + , io + , withNonOption + , withOption ) where -import qualified System.Console.Action.Internal as Action -import qualified System.Console.Options as Options +import System.Console.Internal + ( + Command(Command) + , Action(Action,run,options,nonOptions) + , Option(Option) + , Identifier + ) +import qualified System.Console.Argument as Argument -import Control.Applicative ((<$>)) -import Control.Arrow ((&&&),second) -import Control.Exception (tryJust) -import Control.Monad (guard,join) -import qualified Data.Set as Set -import qualified Data.Tree as Tree -import Data.Foldable (foldMap) -import Data.Traversable (traverse) -import qualified Fez.Data.Conf as Conf -import qualified System.Console.GetOpt as GetOpt -import System.Directory (getHomeDirectory) -import System.Environment.UTF8 (getArgs) -import System.Exit (exitFailure) -import System.IO (readFile) -import System.IO.Error (isDoesNotExistError) -import qualified Text.PrettyPrint.ANSI.Leijen as PP +import qualified Data.Map as Map +import qualified Data.Tree as Tree +import System.Exit (exitFailure) -- | @Commands s@ is a tree of commands. It represents the whole set of -- possible commands of a program. -type Commands setting - = Tree.Tree (Command setting) +type Commands + = Tree.Tree Command --- | 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 - -- ^ 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; also, the union of this field, over all commands in - -- the command tree, determines which options will be recognised when - -- parsing the configuration file and command line. - , 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 - result <- tryJust (guard . isDoesNotExistError) (readFile $ home ++ "/" ++ configFile) - return $ either (const []) Conf.parseToArgs result - --- Load configuration file and parse the command line into settings --- and non-options. -load :: Commands c -> IO ([String],[Options.Setting c]) -load commands = do - let options = Set.toList $ collectOptions commands - fileArgs <- fromDisk $ '.' : name (Tree.rootLabel commands) - (opts,nonOpts,errors) <- GetOpt.getOpt GetOpt.Permute options . (++) fileArgs <$> getArgs - if null errors - then either ((>> exitFailure) . putStrLn) (return . (,) nonOpts) $ sequence opts - else traverse putStrLn errors >> showUsage commands >> exitFailure +-- | A simple action, taking no argument, and having no options. +io :: IO () -> Action +io h = Action r [] [] where + r [] _ = h + r rest _ = putStrLn e >> exitFailure where + e = "Error: unused non-option or unrecognised command: " ++ unwords rest --- | Load the configuration file (if present), and run the action given on the command line. --- You may use this function, with appropriate arguments, as your @main@ function. +-- | Create an action that takes an argument (non-option). -- --- 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.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 - --- | 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) - descr c = flip (PP.<$>) $ PP.string (description c) - nonOpts c = if null (applicableNonOptions c) - then id - else flip (PP.<+>) $ PP.cat . PP.punctuate PP.space . map PP.text $ applicableNonOptions c - opts c = if null (applicableOptions c) - then id - else flip (PP.<$>) . PP.indent 2 . PP.vsep . map opt $ applicableOptions c - opt (GetOpt.Option short long a descr) = list 5 "-" arg (map (: []) short) - PP.<+> list 20 "--" arg long PP.<+> PP.string descr where - arg = case a of - GetOpt.NoArg _ -> PP.empty - GetOpt.ReqArg _ x -> PP.equals PP.<> PP.string x - GetOpt.OptArg _ x -> PP.brackets (PP.equals PP.<> PP.string x) - 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 c -> Set.Set (GetOpt.OptDescr (Either String (Options.Setting c))) -collectOptions = foldMap (Set.fromList . applicableOptions) +-- 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 + { + 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) + , options = options (f undefined) + } -instance Eq (GetOpt.OptDescr a) where - (GetOpt.Option _ x _ _) == (GetOpt.Option _ y _ _) = head x == head y -instance Ord (GetOpt.OptDescr a) where - (GetOpt.Option _ x _ _) `compare` (GetOpt.Option _ y _ _) = compare (head x) (head y) +-- | Create an action that takes an option. +-- +-- 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 (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 + Right a -> run (f a) nonOpts opts + , nonOptions = nonOptions (f undefined) + , options = optDescr : options (f undefined) + } diff --git a/src/System/Console/ConfigFile.hs b/src/System/Console/ConfigFile.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/ConfigFile.hs @@ -0,0 +1,48 @@ +module System.Console.ConfigFile + ( + readFromFile + ) where + + +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 qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (isJust) +import qualified Data.Tree as Tree +import qualified Fez.Data.Conf as Fez +import System.Directory (getHomeDirectory) +import System.IO.Error (isDoesNotExistError) + + +type UserCommand = [String] + +readFromFile :: Commands -> UserCommand -> IO [String] +readFromFile commands command = do + home <- getHomeDirectory + let configFile = '.' : name (Tree.rootLabel commands) + fileContents <- either (const "") id <$> tryJust (guard . isDoesNotExistError) (readFile $ home ++ "/" ++ configFile) + return $ Fez.parseToArgs . unlines $ filterSections command fileContents + +filterSections :: UserCommand -> String -> [String] +filterSections c = concat . map snd . filter (flip isPrefixOf c . fst) . map parseSection . s . lines + where + + s :: [String] -> [[String]] + s = split $ keepDelimsR $ whenElt (isJust . header) + + header :: String -> Maybe [String] + header ('[' : xs) = Just . words . takeWhile (/= ']') $ xs + header _ = Nothing + + parseSection :: [String] -> ([String],[String]) + parseSection (h : rest) = case header h of + Just c -> (c,rest) + Nothing -> ([],h : rest) + parseSection [] = ([],[]) diff --git a/src/System/Console/Internal.hs b/src/System/Console/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Internal.hs @@ -0,0 +1,42 @@ +module System.Console.Internal where + + +import Data.Map (Map) +import qualified System.Console.GetOpt as GetOpt + + +-- | An @Action@ is an @IO@ action, which may take arguments +-- (\"non-options\") and options from the command line. +data Action + = Action + { + run :: [String] -> Map Identifier (Maybe String) -> IO () + , nonOptions :: [String] + , options :: [GetOpt.OptDescr (Identifier,Maybe String)] + } + +data Identifier = Short Char | Long String + deriving (Eq,Ord) + +-- | A value of type @Option a@ describes an option, that delivers a value +-- to the program of type @a@. +data Option a = Option + Identifier + (GetOpt.OptDescr (Identifier,Maybe String)) + a + (Maybe String -> Either String a) + + +-- | A @Command@ 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. +data Command + = Command + { + name :: String + -- ^ This determines which command is executed, depending on the command line. + , description :: String + -- ^ For usage info. + , action :: Action + -- ^ The actual action performed by this command. + } diff --git a/src/System/Console/Options.hs b/src/System/Console/Options.hs deleted file mode 100644 --- a/src/System/Console/Options.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# 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 - ( - Configuration(set) - , Setting - , apply - - , create - - , Type(ConT) -- Useful for passing types of settings to 'create'. - ) where - - -import Data.Char (toUpper) -import Data.List (foldl') -import Language.Haskell.TH - - --- | 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 - -instance Configuration () where - type Setting () = () - set _ _ = () - -apply :: forall c. (Configuration c) => [Setting c] -> c -> c -apply = flip (foldl' (flip set)) - --- Necessary to avoid TH staging error. -setName = 'set - --- | '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" - 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 s $ flip map settings $ \ (n,_) -> Clause - [ConP (mkName $ capitalise n) [VarP x],VarP y] - (NormalB $ RecUpdE (VarE y) [(mkName $ n ++ "_",VarE x)] ) - [] - let configurationInstance = InstanceD [] (ConT ''Configuration `AppT` ConT (mkName configurationName)) - [ - TySynInstD ''Setting [ConT $ mkName configurationName] (ConT $ mkName settingName) - , FunD setName [Clause [] (NormalB $ VarE s) []] - ] - return $ configurationType : settingType : setFunction : configurationInstance : [] - where - capitalise :: String -> String - capitalise [] = [] - capitalise (x : xs) = toUpper x : xs diff --git a/src/System/Console/Program.hs b/src/System/Console/Program.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Program.hs @@ -0,0 +1,133 @@ +-- | This module contains functions to build a console program, that parses +-- the command line (and a configuration file), divides it into modes/commands, +-- options and non-options, and executes the corresponding action from a tree +-- of available commands. +-- +-- These commands can be constructed using the module "System.Console.Command". +module System.Console.Program + ( + -- * Using a command tree to construct a program + single + , interactive + , showUsage + + -- * Configuration file + -- $configfile + ) where + + +import System.Console.Command (Commands,Command) +import System.Console.ConfigFile (readFromFile) +import System.Console.Internal (run,options,nonOptions,action,description,name) + +import Control.Applicative ((<|>),(*>)) +import Control.Arrow ((&&&),second) +import Control.Monad (when) +import Control.Monad.Trans.Class (lift) +import qualified Data.Map as Map +import Data.Traversable (traverse) +import qualified Data.Tree as Tree +import qualified System.Console.ANSI as ANSI +import qualified System.Console.GetOpt as GetOpt +import qualified System.Console.Haskeline as Haskeline +import System.Environment (getArgs) +import System.Exit (exitFailure,exitSuccess) +import System.IO (readFile) +import qualified Text.Parsec as P +import qualified Text.PrettyPrint.ANSI.Leijen as PP + + +-- $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 +-- root of the command tree (usually the name of the program). +-- +-- Settings in this file are of the form +-- @ +-- option-name=option-value +-- @ +-- , see the documentation of the package fez-conf for details. The format of +-- the \"option-value\" part depends on the type of the option argument; see +-- "System.Console.Argument". +-- +-- Sections can be defined for settings applying to a single command, +-- using the name of a command, enclosed in square brackets, as section header: +-- @ +-- [command1] +-- option-for-command1=true +-- @. + + +-- Parse the given list of strings into a command, non-options and options. +parse :: Commands -> [String] -> IO () +parse commands args = do + let (commandString,command,restArgs) = select commands args + fileArgs <- readFromFile commands commandString + let (opts,nonOpts,errors) = GetOpt.getOpt GetOpt.Permute (options $ action command) (fileArgs ++ restArgs) + let optsMap = Map.fromList opts + when (not $ null errors) $ + traverse putStrLn errors >> exitFailure + run (action command) nonOpts optsMap + +-- Select the right command from the command tree, and return the rest of the command line. +select :: Commands -> [String] -> ([String],Command,[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) + Just cs -> let (xs',c,rest) = select cs xs in (x : xs',c,rest) + +-- | Load the configuration file (if present), and run the action given on the command line. +-- 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. +single :: Commands -> IO () +single commands = parse commands =<< 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 commands = do + Haskeline.runInputT Haskeline.defaultSettings $ sequence_ . repeat $ one + where + one = do + lift $ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity] + lift $ putStr $ name (Tree.rootLabel commands) + lift $ ANSI.setSGR [ANSI.Reset] + line <- maybe (lift exitSuccess) return =<< Haskeline.getInputLine ": " + case words' line of + Left e -> lift $ putStrLn e + Right ws -> lift $ parse commands ws + +words' :: String -> Either String [String] +words' = either (Left . show) Right . P.parse p "" where + p = P.optional space *> P.sepEndBy (quoted <|> unquoted) space + unquoted = P.many1 $ P.noneOf [' '] + space = P.many1 $ P.char ' ' + quoted = P.between quote quote . P.many $ + P.try (escaped quote) <|> escaped escape <|> P.noneOf ['"','\\'] + quote = P.char '"' + escape = P.char '\\' + escaped x = escape *> x + +-- | Print usage info for the program to stdout. +showUsage :: Commands -> IO () +showUsage = 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) + nonOpts c = let n = nonOptions $ action c in if null n + then id + else flip (PP.<+>) $ PP.cat . PP.punctuate PP.space . map PP.text $ n + opts c = let o = options $ action c in if null o + then id + else flip (PP.<$>) . PP.indent 2 . PP.vsep . map opt $ o + opt (GetOpt.Option short long a descr) = list 5 "-" arg (map (: []) short) + PP.<+> list 20 "--" arg long PP.<+> PP.string descr where + arg = case a of + GetOpt.NoArg _ -> PP.empty + GetOpt.ReqArg _ x -> PP.equals PP.<> PP.string x + GetOpt.OptArg _ x -> PP.brackets (PP.equals PP.<> PP.string x) + 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)