console-program 0.4.0.2 → 0.4.0.3
raw patch · 6 files changed
+60/−40 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- console-program.cabal +1/−1
- src/System/Console/Argument.hs +5/−4
- src/System/Console/Command.hs +3/−10
- src/System/Console/ConfigFile.hs +12/−7
- src/System/Console/Internal.hs +25/−10
- src/System/Console/Program.hs +14/−8
console-program.cabal view
@@ -1,5 +1,5 @@ name: console-program-version: 0.4.0.2+version: 0.4.0.3 cabal-Version: >= 1.6 license: BSD3 author: Arie Peterson
src/System/Console/Argument.hs view
@@ -6,7 +6,7 @@ Option , option - , Type (Type,parser,name,defaultValue)+ , Type(Type,parser,name,defaultValue) -- * Argument types , optional@@ -20,7 +20,7 @@ ) where -import System.Console.Internal (Option(Option),Identifier(Short,Long))+import System.Console.Internal hiding (name) import Data.Char (toLower) import Data.List.HT (viewR)@@ -61,9 +61,10 @@ -> 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)+ names = map Short short ++ map Long long+ identifier = identify names in Option- identifier+ names (GetOpt.Option short long
src/System/Console/Command.hs view
@@ -22,13 +22,6 @@ import System.Console.Internal- (- Command(Command,name,description,action,shorten)- , Action(Action,run,options,nonOptions,ignoringOptions)- , Option(Option)- , Identifier- , ConsoleProgramException(UnknownCommand)- ) import qualified System.Console.Argument as Argument import Control.Exception (throwIO)@@ -87,13 +80,13 @@ -- The first parameter is a description of the option; such a value can be -- constructed using 'System.Console.Argument.option'. withOption :: (MonadIO m) => Option a -> (a -> Action m) -> Action m-withOption (Option identifier optDescr def p) f = Action+withOption (Option names optDescr def p) f = Action {- run = \ nonOpts opts -> case maybe (Right def) p $ Map.lookup identifier opts of+ run = \ nonOpts opts -> case maybe (Right def) p $ Map.lookup (identify names) opts of Left e -> liftIO $ putStrLn e >> exitFailure Right a -> run (f a) nonOpts opts , nonOptions = nonOptions (f undefined)- , options = optDescr : options (f undefined)+ , options = ((identify names,names),optDescr) : options (f undefined) , ignoringOptions = ignoringOptions (f undefined) }
src/System/Console/ConfigFile.hs view
@@ -12,28 +12,28 @@ import Control.Monad (guard) import Control.Monad.IO.Class (MonadIO,liftIO) import Data.List (isPrefixOf,concat,break)-import Data.List.Split (Splitter,split,whenElt,keepDelimsR)-import qualified Data.Map as Map+import qualified Data.List.Split as Split+import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (isJust)-import qualified Data.Tree as Tree+import qualified Data.Tree as Tree import System.Directory (getAppUserDataDirectory) import System.IO.Error (isDoesNotExistError) -readFromFile :: (MonadIO m) => Commands m -> UserCommand -> m Settings+readFromFile :: (MonadIO m) => Commands m -> UserCommand -> m [Setting] readFromFile commands command = liftIO $ do dataDir <- getAppUserDataDirectory $ name (Tree.rootLabel commands) let configFile = dataDir ++ "/" ++ "config" fileContents <- either (const "") id <$> tryJust (guard . isDoesNotExistError) (readFile configFile)- return . Map.fromList . map parseSetting $ relevantLines command fileContents+ return . map parseSetting $ relevantLines command fileContents relevantLines :: UserCommand -> String -> [String] relevantLines c = concat . map snd . filter (flip isPrefixOf c . fst) . map parseSection . s . lines where s :: [String] -> [[String]]- s = split $ keepDelimsR $ whenElt (isJust . header) + s = Split.split . Split.keepDelimsL $ Split.whenElt (isJust . header) header :: String -> Maybe UserCommand header ('[' : xs) = Just . words . takeWhile (/= ']') $ xs@@ -47,4 +47,9 @@ parseSetting :: String -> Setting parseSetting s = let (i,v) = break (== '=') s in- (Long i,if null v then Nothing else Just v)+ (+ Long i+ , case v of+ [] -> Nothing+ '=' : rest -> Just rest+ )
src/System/Console/Internal.hs view
@@ -17,28 +17,43 @@ { run :: [String] -> Settings -> m () , nonOptions :: [String]- , options :: [GetOpt.OptDescr Setting]- , ignoringOptions :: [GetOpt.OptDescr Setting]+ , options :: [((Identifier,[OptionName]),GetOpt.OptDescr CanonicalSetting)]+ , ignoringOptions :: [GetOpt.OptDescr CanonicalSetting] } -data Identifier+-- | A value of type @Option a@ describes an option, that delivers a value+-- to the program of type @a@.+data Option a = Option+ [OptionName]+ (GetOpt.OptDescr (Identifier,Maybe String))+ a+ (Maybe String -> Either String a)++data OptionName = Short Char | Long String deriving (Eq,Ord)+instance Show OptionName where+ show (Short c) = '-' : c : []+ show (Long i) = "--" ++ i +-- The @Identifier@ of an option should identify it uniquely.+newtype Identifier+ = Id OptionName+ deriving (Eq,Ord)+ type Setting+ = (OptionName,Maybe String)++type CanonicalSetting = (Identifier,Maybe String) type Settings = Map Identifier (Maybe String) --- | 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 Setting)- a- (Maybe String -> Either String a)+identify :: [OptionName] -> Identifier+identify (n : _) = Id n+identify _ = error "System.Console.Internal.identify: option without option names." -- | A @Command m@ is an action (in the monad @m@), together with some
src/System/Console/Program.hs view
@@ -33,13 +33,13 @@ ) import Control.Applicative (Applicative,(<|>),(*>))-import Control.Arrow ((&&&),second)+import Control.Arrow ((&&&),first) import Control.Concurrent (myThreadId) import Control.Exception (throwTo,AsyncException(UserInterrupt)) import Control.Monad (when,void) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Trans.Class (lift)-import Data.List (isPrefixOf)+import Data.List (isPrefixOf,concatMap) import qualified Data.Map as Map import Data.Traversable (traverse) import qualified Data.Tree as Tree@@ -63,9 +63,8 @@ -- @ -- 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".+-- 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:@@ -82,12 +81,19 @@ fileSettings <- readFromFile commands commandString let (opts,nonOpts,errors) = GetOpt.getOpt GetOpt.Permute- (options (action command) ++ ignoringOptions (action command))+ (map snd (options $ action command) ++ ignoringOptions (action command)) restArgs when (not $ null errors) . void $ traverse (liftIO . putStrLn) errors let commandLineSettings = Map.fromList opts- settings = commandLineSettings `Map.union` fileSettings+ optionIndex = Map.fromList .+ concatMap (\ ((i,names),_) -> map (flip (,) i) names) .+ options $ action command+ lookupSetting = maybe+ (error "System.Console.Program.parse: option not found")+ id . flip Map.lookup optionIndex+ identifiedFileSettings = Map.fromList $ map (first lookupSetting) fileSettings+ settings = commandLineSettings `Map.union` identifiedFileSettings run (action command) nonOpts settings -- Select the right command from the command tree, and return the rest of the command line.@@ -169,7 +175,7 @@ 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+ else flip (PP.<$>) . PP.indent 2 . PP.vsep . map (opt . snd) $ o opt (GetOpt.Option short long a descr) = list 5 "-" (arg id) (map (: []) short) PP.<+> list 20 "--" (arg (PP.equals PP.<>)) long PP.<+> PP.string descr where arg maybeEq = case a of