diff --git a/console-program.cabal b/console-program.cabal --- a/console-program.cabal +++ b/console-program.cabal @@ -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 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 @@ -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 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 @@ -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) } diff --git a/src/System/Console/ConfigFile.hs b/src/System/Console/ConfigFile.hs --- a/src/System/Console/ConfigFile.hs +++ b/src/System/Console/ConfigFile.hs @@ -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 + ) diff --git a/src/System/Console/Internal.hs b/src/System/Console/Internal.hs --- a/src/System/Console/Internal.hs +++ b/src/System/Console/Internal.hs @@ -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 diff --git a/src/System/Console/Program.hs b/src/System/Console/Program.hs --- a/src/System/Console/Program.hs +++ b/src/System/Console/Program.hs @@ -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