console-program (empty) → 0.1.0.0
raw patch · 6 files changed
+325/−0 lines, 6 filesdep +ansi-wl-pprintdep +basedep +containerssetup-changed
Dependencies added: ansi-wl-pprint, base, containers, directory, fez-conf, parsec-extra, template-haskell, transformers, utf8-string, utility-ht
Files
- Setup.hs +4/−0
- console-program.cabal +43/−0
- src/System/Console/Action.hs +33/−0
- src/System/Console/Argument.hs +79/−0
- src/System/Console/Command.hs +105/−0
- src/System/Console/Options.hs +61/−0
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ console-program.cabal view
@@ -0,0 +1,43 @@+Name: console-program+Version: 0.1.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+Description:+ This library provides an infrastructure to build command line programs. It provides the following features:+ - declare any number of "actions" (commands, or modes of operation, of the program);+ - declare options of the program;+ - 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:+ - 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;+ - it parses a configuration file, in addition to the command line arguments.+Category: System+Build-Type: Simple++Source-repository head+ Type: darcs+ Location: http://patch-tag.com/r/AriePeterson/console-program++Library+ Build-Depends:+ base == 4.*,+ transformers == 0.2.*,+ containers >= 0.1 && < 0.4,+ directory == 1.0.*,+ utf8-string >= 0.3.5 && < 0.4,+ fez-conf == 1.0.*,+ template-haskell,+ ansi-wl-pprint == 0.5.*,+ utility-ht == 0.0.5.*,+ parsec-extra == 0.1.*+ Exposed-Modules:+ System.Console.Command,+ System.Console.Action,+ System.Console.Argument,+ System.Console.Options+ Hs-Source-Dirs: src
+ src/System/Console/Action.hs view
@@ -0,0 +1,33 @@+module System.Console.Action+ (+ Action+ , run+ + , readerT+ , simple+ , withArgument+ ) 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)++simple :: IO () -> Action o+simple = Action . const . const++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
+ src/System/Console/Argument.hs view
@@ -0,0 +1,79 @@+module System.Console.Argument+ (+ Type (Type,parser,name,defaultValue)+ + , option+ + , optional+ , string+ , boolean+ , directory+ , file+ , device+ , natural+ , integer+ ) where+++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+++data Type a+ = Type+ {+ parser :: String -> 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) }++option :: (a -> s) -> [Char] -> [String] -> Type a -> String -> GetOpt.OptDescr (Either String s)+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++-- Common argument types++optional :: a -> Type a -> Type a+optional x t = t { defaultValue = Just x }++string :: Type String+string = Type (const Right) "STRING" Nothing++boolean :: Type Bool+boolean = Type+ {+ name = "BOOL"+ , parser = \ _ y -> maybe (e y) Right . flip Map.lookup m . map toLower $ y+ , defaultValue = Just True+ }+ where+ m = Map.fromList [("1",True),("0",False),("true",True),("false",False)]+ e y = Left $ "Argument " ++ show y ++ " could not be recognised as a boolean."++natural :: Type Integer+natural = Type { name = "INT (natural)", parser = const (P.parseM P.natural ""), defaultValue = Nothing }++integer :: Type Integer+integer = Type { name = "INT", parser = const (P.parseM P.integer ""), defaultValue = Nothing }++directory :: Type FilePath+directory = Type { name = "DIR", parser = const (Right . stripTrailingSlash), defaultValue = Nothing }+ where+ stripTrailingSlash x = case viewR x of+ Nothing -> ""+ Just (i,l)+ | l == '/' -> i+ | otherwise -> x++file :: Type FilePath+file = string { name = "FILE" }++device :: Type FilePath+device = string { name = "DEVICE" }
+ src/System/Console/Command.hs view
@@ -0,0 +1,105 @@+module System.Console.Command+ (+ Commands+ , Command (Command,name,applicableNonOptions,applicableOptions,description,action)+ + , single+ , showUsage+ ) where+++import qualified System.Console.Action as Action+import qualified System.Console.Options as Options++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+++-- | @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)++-- | 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+ = Command+ {+ name :: String+ , applicableNonOptions :: [String]+ , applicableOptions :: [GetOpt.OptDescr (Either String s)]+ , description :: String+ , action :: Action.Action (Options.Options s)+ }++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 s -> IO ([String],[s])+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++-- | 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++-- 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 (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 ()+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 o -> Set.Set (GetOpt.OptDescr (Either String o))+collectOptions = foldMap (Set.fromList . applicableOptions)++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)
+ src/System/Console/Options.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TypeFamilies,TemplateHaskell,ScopedTypeVariables #-}+module System.Console.Options+ (+ Options+ , Setting(set)+ , 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 @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 needs.+class Setting s where+ type Options s+ set :: s -> Options s -> Options s++setName = 'set++apply :: forall s. (Setting s) => [s] -> Options s -> Options s+apply = flip (foldl' (flip set))++{-+instance Setting (Endo a) where+ type Options (Endo a) = a+ set (Endo f) = f+-}++-- | '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+ x <- newName "x"+ y <- newName "y"+ let optionType = DataD [] (mkName optionsName) [] [RecC (mkName optionsName) $ 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+ [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))+ [+ TySynInstD ''Options [ConT $ mkName settingName] (ConT $ mkName optionsName)+ , FunD setName [Clause [] (NormalB $ VarE $ mkName set) []]+ ]+ return $ optionType : settingType : setFunction : settingsInstance : []+ where+ capitalise :: String -> String+ capitalise [] = []+ capitalise (x : xs) = toUpper x : xs