console-program 0.2.0.1 → 0.3.0.0
raw patch · 12 files changed
+353/−349 lines, 12 filesdep +ansi-terminaldep +haskelinedep +parsecdep −template-haskelldep −utf8-stringdep ~ansi-wl-pprintdep ~containersdep ~directory
Dependencies added: ansi-terminal, haskeline, parsec, split, transformers
Dependencies removed: template-haskell, utf8-string
Dependency ranges changed: ansi-wl-pprint, containers, directory, utility-ht
Files
- Examples/Full.hs +11/−18
- Examples/Options.hs +0/−34
- Examples/Simple.hs +7/−9
- console-program.cabal +19/−14
- src/System/Console/Action.hs +0/−11
- src/System/Console/Action/Internal.hs +0/−45
- src/System/Console/Argument.hs +33/−16
- src/System/Console/Command.hs +60/−135
- src/System/Console/ConfigFile.hs +48/−0
- src/System/Console/Internal.hs +42/−0
- src/System/Console/Options.hs +0/−67
- src/System/Console/Program.hs +133/−0
Examples/Full.hs view
@@ -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
− Examples/Options.hs
@@ -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- }
Examples/Simple.hs view
@@ -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
console-program.cabal view
@@ -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
− src/System/Console/Action.hs
@@ -1,11 +0,0 @@-module System.Console.Action- (- Action- - , simple- , withArgument- , usingConfiguration- ) where---import System.Console.Action.Internal
− src/System/Console/Action/Internal.hs
@@ -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)
src/System/Console/Argument.hs view
@@ -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).
src/System/Console/Command.hs view
@@ -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)+ }
+ src/System/Console/ConfigFile.hs view
@@ -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 [] = ([],[])
+ src/System/Console/Internal.hs view
@@ -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.+ }
− src/System/Console/Options.hs
@@ -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
+ src/System/Console/Program.hs view
@@ -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)