packages feed

console-program 0.1.0.2 → 0.2.0.0

raw patch · 9 files changed

+260/−89 lines, 9 filesdep −transformers

Dependencies removed: transformers

Files

+ Examples/Full.hs view
@@ -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+  }
+ Examples/Options.hs view
@@ -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+  }
+ Examples/Simple.hs view
@@ -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
console-program.cabal view
@@ -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
src/System/Console/Action.hs view
@@ -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
+ src/System/Console/Action/Internal.hs view
@@ -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)
src/System/Console/Argument.hs view
@@ -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       -> ""
src/System/Console/Command.hs view
@@ -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
src/System/Console/Options.hs view
@@ -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 []       = []