diff --git a/lib/Options.hs b/lib/Options.hs --- a/lib/Options.hs +++ b/lib/Options.hs @@ -1,958 +1,944 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- Module: Options --- License: MIT --- --- The @options@ package lets library and application developers easily work --- with command-line options. --- --- The following example is a full program that can accept two options, --- @--message@ and @--quiet@: --- --- @ ---{-\# LANGUAGE TemplateHaskell \#-} --- ---import Options --- ---'defineOptions' \"MainOptions\" $ do --- 'stringOption' \"optMessage\" \"message\" \"Hello world!\" --- \"A message to show the user.\" --- 'boolOption' \"optQuiet\" \"quiet\" False --- \"Whether to be quiet.\" --- ---main :: IO () ---main = 'runCommand' $ \\opts args -> do --- if optQuiet opts --- then return () --- else putStrLn (optMessage opts) --- @ --- --- >$ ./hello --- >Hello world! --- >$ ./hello --message='ciao mondo' --- >ciao mondo --- >$ ./hello --quiet --- >$ --- --- In addition, this library will automatically create documentation options --- such as @--help@ and @--help-all@: --- --- >$ ./hello --help --- >Help Options: --- > -h, --help Show option summary. --- > --help-all Show all help options. --- > --- >Application Options: --- > --message A message to show the user. --- > --quiet Whether to be quiet. --- -module Options - ( - -- * Options - Options - , defaultOptions - - -- * Commands - , runCommand - - -- ** Subcommands - , Subcommand - , subcommand - , runSubcommand - - -- * Defining options - , defineOptions - - -- ** Simple option definitions - , boolOption - , stringOption - , stringsOption - , textOption - , textsOption - , pathOption - , intOption - , integerOption - , floatOption - , doubleOption - - -- ** Using imported options - , ImportedOptions - , importedOptions - , options - - -- ** Advanted option definitions - , Option - , option - , optionShortFlags - , optionLongFlags - , optionDefault - , optionType - , optionDescription - , optionGroup - - -- ** Option types - , OptionType - - , optionTypeBool - - , optionTypeString - , optionTypeText - , optionTypeFilePath - - , optionTypeInt - , optionTypeInt8 - , optionTypeInt16 - , optionTypeInt32 - , optionTypeInt64 - , optionTypeWord - , optionTypeWord8 - , optionTypeWord16 - , optionTypeWord32 - , optionTypeWord64 - , optionTypeInteger - - , optionTypeFloat - , optionTypeDouble - - , optionTypeMaybe - , optionTypeList - , optionTypeSet - , optionTypeMap - , optionTypeEnum - - -- * Option groups - , Group - , group - , groupTitle - , groupDescription - - -- * Parsing argument lists - , Parsed - , parsedError - , parsedHelp - - -- ** Parsing options - , ParsedOptions - , parsedOptions - , parsedArguments - , parseOptions - - -- ** Parsing subcommands - , ParsedSubcommand - , parsedSubcommand - , parseSubcommand - ) where - -import Control.Monad (forM, unless, when) -import Control.Monad.Error (ErrorT, runErrorT, throwError) -import Control.Monad.IO.Class -import Control.Monad.Reader (Reader, runReader, ask) -import Control.Monad.State (StateT, execStateT, get, modify) -import Data.List (foldl', intercalate) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified System.Environment -import System.Exit (exitFailure, exitSuccess) -import System.IO - -import qualified Filesystem.Path as Path -import qualified Filesystem.Path.Rules as Path -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (mkNameG_tc) - -import Options.Help -import Options.OptionTypes -import Options.Tokenize -import Options.Types -import Options.Util - --- | Options are defined together in a single data type, which will be an --- instance of 'Options'. --- --- See 'defineOptions' for details on defining instances of 'Options'. --- --- See 'options' for details on including imported 'Options' types in locally --- defined options. -class Options a where - optionsDefs :: OptionDefinitions a - optionsParse' :: TokensFor a -> Either String a - optionsMeta :: OptionsMeta a - -optionsParse :: Options a => TokensFor a -> Either String (a, [String]) -optionsParse tokens@(TokensFor _ args) = case optionsParse' tokens of - Left err -> Left err - Right opts -> Right (opts, args) - -data OptionsMeta a = OptionsMeta - { optionsMetaName :: Name - , optionsMetaKeys :: Set.Set String - , optionsMetaShortFlags :: Set.Set Char - , optionsMetaLongFlags :: Set.Set String - } - --- | An options value containing only the default values for each option. --- This is equivalent to the options value when parsing an empty argument --- list. -defaultOptions :: Options a => a -defaultOptions = opts where - parsed = parseOptions [] - opts = case parsedOptions parsed of - Just v -> v - Nothing -> error ("Internal error while parsing default options: " ++ (case parsedError parsed of - Just err -> err - Nothing -> "(no error provided)")) - -newtype OptionsM a = OptionsM { unOptionsM :: StateT OptionsDeclState (ErrorT String (Reader Loc)) a } - -data OptionsDeclState = OptionsDeclState - { stDecls :: [(Name, Type, Q Exp, Q Exp)] - , stSeenFieldNames :: Set.Set String - , stSeenKeys :: Set.Set String - , stSeenShortFlags :: Set.Set Char - , stSeenLongFlags :: Set.Set String - } - -instance Monad OptionsM where - return = OptionsM . return - m >>= f = OptionsM (unOptionsM m >>= (unOptionsM . f)) - -runOptionsM :: Loc -> OptionsM () -> Either String OptionsDeclState -runOptionsM loc (OptionsM m) = runReader (runErrorT (execStateT m initState)) loc where - initState = OptionsDeclState [] Set.empty Set.empty Set.empty Set.empty - --- | Defines a new data type, containing fields for application or library --- options. The new type will be an instance of 'Options'. --- --- Example: this use of @defineOptions@: --- --- @ ---'defineOptions' \"MainOptions\" $ do --- 'stringOption' \"optMessage\" \"message\" \"Hello world!\" \"\" --- 'boolOption' \"optQuiet\" \"quiet\" False \"\" --- @ --- --- expands to the following definition: --- --- >data MainOptions = MainOptions --- > { optMessage :: String --- > , optQuiet :: Bool --- > } --- > --- >instance Options MainOptions --- -defineOptions :: String -> OptionsM () -> Q [Dec] -defineOptions rawName optionsM = do - loc <- location - let dataName = mkName rawName - declState <- case runOptionsM loc optionsM of - Left err -> fail err - Right st -> return st - let fields = stDecls declState - - let dataDec = DataD [] dataName [] [RecC dataName - [(fName, NotStrict, t) | (fName, t, _, _) <- fields] - ][] - - exp_optionsDefs <- getOptionsDefs fields - exp_optionsParse <- getOptionsParse dataName fields - exp_optionsMeta <- getOptionsMeta loc rawName declState - let instanceDec = InstanceD [] (AppT (ConT ''Options) (ConT dataName)) - [ ValD (VarP 'optionsDefs) (NormalB exp_optionsDefs) [] - , ValD (VarP 'optionsParse') (NormalB exp_optionsParse) [] - , ValD (VarP 'optionsMeta) (NormalB exp_optionsMeta) [] - ] - - return [dataDec, instanceDec] - -getOptionsDefs :: [(Name, Type, Q Exp, Q Exp)] -> Q Exp -getOptionsDefs fields = do - infoExps <- forM fields (\(_, _, infoExp, _) -> infoExp) - [| OptionDefinitions (concat $(return (ListE infoExps))) [] |] - -getOptionsParse :: Name -> [(Name, Type, Q Exp, Q Exp)] -> Q Exp -getOptionsParse dataName fields = do - let genBind (_, _, _, qParseExp) = do - varName <- newName "_val" - parseExp <- qParseExp - return (varName, BindS (VarP varName) parseExp) - - names_and_binds <- mapM genBind fields - let names = [n | (n, _) <- names_and_binds] - let binds = [b | (_, b) <- names_and_binds] - - returnExp <- [| return |] - let consExp = foldl' AppE (ConE dataName) (map VarE names) - let parserM = return (DoE (binds ++ [NoBindS (AppE returnExp consExp)])) - [| unParserM $parserM |] - -getOptionsMeta :: Loc -> String -> OptionsDeclState -> Q Exp -getOptionsMeta loc typeName st = do - let pkg = loc_package loc - let mod' = loc_module loc - let keys = Set.toList (stSeenKeys st) - let shorts = Set.toList (stSeenShortFlags st) - let longs = Set.toList (stSeenLongFlags st) - [| OptionsMeta (mkNameG_tc pkg mod' typeName) (Set.fromList keys) (Set.fromList shorts) (Set.fromList longs) |] - -newtype ParserM optType a = ParserM { unParserM :: TokensFor optType -> Either String a } - -instance Monad (ParserM optType) where - return x = ParserM (\_ -> Right x) - m >>= f = ParserM (\env -> case unParserM m env of - Left err -> Left err - Right x -> unParserM (f x) env) - -putOptionDecl :: Name -> Type -> Q Exp -> Q Exp -> OptionsM () -putOptionDecl name qtype infoExp parseExp = OptionsM (modify (\st -> st - { stDecls = stDecls st ++ [(name, qtype, infoExp, parseExp)] - })) - --- | Defines a new option in the current options type. --- --- All options must have a /field name/ and one or more /flags/. Options may --- also have a default value, a description, or a group. --- --- The field name is how the option will be accessed in Haskell, and is --- typically prefixed with \"opt\". This is used to define a record field, --- and must be a valid Haskell field name (see 'defineOptions' for details). --- --- The /flags/ are how the user specifies an option on the command line. Flags --- may be /short/ or /long/. See 'optionShortFlags' and 'optionLongFlags' for --- details. --- --- @ ---'option' \"optPort\" (\\o -> o --- { 'optionLongFlags' = [\"port\"] --- , 'optionDefault' = \"80\" --- , 'optionType' = 'optionTypeWord16' --- } --- @ -option :: String -- ^ Field name - -> (Option String -> Option a) -- ^ Option definition - -> OptionsM () -option fieldName f = do - let emptyGroup = Group - { groupName = Nothing - , groupTitle = "" - , groupDescription = "" - } - let opt = f (Option - { optionShortFlags = [] - , optionLongFlags = [] - , optionDefault = "" - , optionType = optionTypeString - , optionDescription = "" - , optionGroup = emptyGroup - }) - - loc <- OptionsM ask - let key = loc_package loc ++ ":" ++ loc_module loc ++ ":" ++ fieldName - - let shorts = optionShortFlags opt - let longs = optionLongFlags opt - let def = optionDefault opt - - let desc = optionDescription opt - - let optGroup = optionGroup opt - let optGroupDesc = groupTitle optGroup - let optGroupHelpDesc = groupDescription optGroup - let groupInfoExp = case groupName optGroup of - Nothing -> [| Nothing |] - Just n -> [| Just (GroupInfo n optGroupDesc optGroupHelpDesc) |] - - let OptionType thType unary parseOptType parseExp = optionType opt - - checkFieldName fieldName - checkValidFlags fieldName shorts longs - checkUniqueKey key - checkUniqueFlags fieldName shorts longs - - case parseOptType def of - Right _ -> return () - Left err -> OptionsM (throwError ("Invalid default value for option " ++ show fieldName ++ ": " ++ err)) - - OptionsM (modify (\st -> st - { stSeenFieldNames = Set.insert fieldName (stSeenFieldNames st) - , stSeenKeys = Set.insert key (stSeenKeys st) - , stSeenShortFlags = Set.union (Set.fromList shorts) (stSeenShortFlags st) - , stSeenLongFlags = Set.union (Set.fromList longs) (stSeenLongFlags st) - })) - - putOptionDecl - (mkName fieldName) - thType - [| [OptionInfo key shorts longs def unary desc $groupInfoExp] |] - [| parseOptionTok key $parseExp def |] - -parseOptionTok :: String -> (String -> Either String a) -> String -> ParserM optType a -parseOptionTok key p def = do - TokensFor tokens _ <- ParserM (\t -> Right t) - case lookup key tokens of - Nothing -> case p def of - -- shouldn't happen - Left err -> ParserM (\_ -> Left ("Internal error while parsing default options: " ++ err)) - Right a -> return a - Just (flagName, val) -> case p val of - Left err -> ParserM (\_ -> Left ("Value for flag " ++ flagName ++ " is invalid: " ++ err)) - Right a -> return a - -checkFieldName :: String -> OptionsM () -checkFieldName name = do - unless (validFieldName name) - (OptionsM (throwError ("Option field name " ++ show name ++ " is invalid."))) - st <- OptionsM get - when (Set.member name (stSeenFieldNames st)) - (OptionsM (throwError ("Duplicate definitions of field " ++ show name ++ "."))) - -checkUniqueKey :: String -> OptionsM () -checkUniqueKey key = do - st <- OptionsM get - when (Set.member key (stSeenKeys st)) - (OptionsM (throwError ("Option key " ++ show key ++ " has already been defined. This should never happen; please send an error report to the maintainer of the 'options' package."))) - -checkValidFlags :: String -> [Char] -> [String] -> OptionsM () -checkValidFlags fieldName shorts longs = do - -- Check that at least one flag is defined (in either 'shorts' or 'longs'). - when (length shorts == 0 && length longs == 0) - (OptionsM (throwError ("Option " ++ show fieldName ++ " does not define any flags."))) - - -- Check that 'shorts' contains only non-repeated letters and digits - when (hasDuplicates shorts) - (OptionsM (throwError ("Option " ++ show fieldName ++ " has duplicate short flags."))) - case filter (not . validShortFlag) shorts of - [] -> return () - invalid -> OptionsM (throwError ("Option " ++ show fieldName ++ " has invalid short flags " ++ show invalid ++ ".")) - - -- Check that 'longs' contains only non-repeated, non-empty strings - -- containing {LETTER,DIGIT,-,_} and starting with a letter. - when (hasDuplicates longs) - (OptionsM (throwError ("Option " ++ show fieldName ++ " has duplicate long flags."))) - case filter (not . validLongFlag) longs of - [] -> return () - invalid -> OptionsM (throwError ("Option " ++ show fieldName ++ " has invalid long flags " ++ show invalid ++ ".")) - -checkUniqueFlags :: String -> [Char] -> [String] -> OptionsM () -checkUniqueFlags fieldName shorts longs = do - st <- OptionsM get - - -- Check that none of this option's flags are already used. - let dupShort = do - f <- Set.toList (Set.intersection (stSeenShortFlags st) (Set.fromList shorts)) - return ('-' : [f]) - let dupLong = do - f <- Set.toList (Set.intersection (stSeenLongFlags st) (Set.fromList longs)) - return ("--" ++ f) - let dups = dupShort ++ dupLong - unless (null dups) - (OptionsM (throwError ("Option " ++ show fieldName ++ " uses already-defined flags " ++ show dups ++ "."))) - --- | Include options defined elsewhere into the current options definition. --- --- This is typically used by application developers to include options defined --- in third-party libraries. For example, the author of the \"foo\" library --- would define and export @FooOptions@: --- --- @ ---module Foo (FooOptions, foo) where --- ---import Options --- ---'defineOptions' \"FooOptions\" $ do --- 'boolOption' \"optFrob\" \"frob\" True \"Enable frobnication.\" --- ---foo :: FooOptions -> IO () --- @ --- --- and the author of an application would use @options@ to let users specify --- @--frob@: --- --- @ ---module Main where --- ---import Options ---import Foo --- ---'defineOptions' \"MainOptions\" $ do --- 'boolOption' \"optVerbose\" \"verbose\" False \"Be really loud.\" --- 'options' \"optFoo\" ('importedOptions' :: 'ImportedOptions' FooOptions) --- ---main :: IO () ---main = runCommand $ \\opts args -> do --- foo (optFoo opts) --- @ --- --- Use of 'options' may be arbitrarily nested. Library authors are encouraged --- to aggregate their options into a single top-level type, so application --- authors can include it easily in their own option definitions. -options :: String -> ImportedOptions a -> OptionsM () -options fieldName (ImportedOptions meta) = do - checkFieldName fieldName - - let typeName = optionsMetaName meta - st <- OptionsM get - - -- Check unique keys - let dupKeys = Set.intersection (stSeenKeys st) (optionsMetaKeys meta) - unless (Set.null dupKeys) - (OptionsM (throwError ("Imported options type " ++ show typeName ++ " contains duplicate keys " ++ show (Set.toList dupKeys) ++ ". This should never happen; please send an error report to the maintainer of the 'options' package."))) - - -- Check unique flags - let dupShort = do - f <- Set.toList (Set.intersection (stSeenShortFlags st) (optionsMetaShortFlags meta)) - return ('-' : [f]) - let dupLong = do - f <- Set.toList (Set.intersection (stSeenLongFlags st) (optionsMetaLongFlags meta)) - return ("--" ++ f) - let dups = dupShort ++ dupLong - unless (null dups) - (OptionsM (throwError ("Imported options type " ++ show typeName ++ " contains conflicting definitions for flags " ++ show dups ++ "."))) - - OptionsM (modify (\st' -> st' - { stSeenFieldNames = Set.insert fieldName (stSeenFieldNames st) - , stSeenShortFlags = Set.union (optionsMetaShortFlags meta) (stSeenShortFlags st) - , stSeenLongFlags = Set.union (optionsMetaLongFlags meta) (stSeenLongFlags st) - })) - - putOptionDecl - (mkName fieldName) - (ConT typeName) - [| suboptsDefs $(varE (mkName fieldName)) |] - [| parseSubOptions |] - -newtype ImportedOptions a = ImportedOptions (OptionsMeta a) - -importedOptions :: Options a => ImportedOptions a -importedOptions = ImportedOptions optionsMeta - -castTokens :: TokensFor a -> TokensFor b -castTokens (TokensFor tokens args) = TokensFor tokens args - -parseSubOptions :: Options a => ParserM optType a -parseSubOptions = do - tokens <- ParserM (\t -> Right t) - case optionsParse' (castTokens tokens) of - Left err -> ParserM (\_ -> Left err) - Right x -> return x - -suboptsDefs :: Options a => (b -> a) -> [OptionInfo] -suboptsDefs rec = defsB where - defsB = case defsA rec of - OptionDefinitions opts _ -> opts - defsA :: Options a => (b -> a) -> OptionDefinitions a - defsA _ = optionsDefs - --- | Define an option of type @'Bool'@. This is a simple wrapper around --- 'option'. -boolOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Bool -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -boolOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = if def then "true" else "false" - , optionType = optionTypeBool - , optionDescription = desc - }) - --- | Define an option of type @'String'@. This is a simple wrapper around --- 'option'. -stringOption :: String -- ^ Field name - -> String -- ^ Long flag - -> String -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -stringOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = def - , optionDescription = desc - }) - --- | Define an option of type @['String']@. This is a simple wrapper around --- 'option'. Items are comma-separated. -stringsOption :: String -- ^ Field name - -> String -- ^ Long flag - -> [String] -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -stringsOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = intercalate "," def - , optionType = optionTypeList ',' optionTypeString - , optionDescription = desc - }) - --- | Define an option of type @'Text.Text'@. This is a simple wrapper around --- 'option'. -textOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Text.Text -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -textOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = Text.unpack def - , optionType = optionTypeText - , optionDescription = desc - }) - --- | Define an option of type @['Text.Text']@. This is a simple wrapper around --- 'option'. Items are comma-separated. -textsOption :: String -- ^ Field name - -> String -- ^ Long flag - -> [Text.Text] -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -textsOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = Text.unpack (Text.intercalate (Text.pack ",") def) - , optionType = optionTypeList ',' optionTypeText - , optionDescription = desc - }) - --- | Define an option of type @'Path.FilePath'@. This is a simple wrapper --- around 'option'. -pathOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Path.FilePath -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -pathOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] -#if defined(CABAL_OS_WINDOWS) - , optionDefault = Path.encodeString Path.windows def -#else - , optionDefault = Path.encodeString Path.posix_ghc704 def -#endif - , optionType = optionTypeFilePath - , optionDescription = desc - }) - --- | Define an option of type @'Int'@. This is a simple wrapper around --- 'option'. -intOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Int -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -intOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = show def - , optionType = optionTypeInt - , optionDescription = desc - }) - --- | Define an option of type @'Integer'@. This is a simple wrapper around --- 'option'. -integerOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Integer -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -integerOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = show def - , optionType = optionTypeInteger - , optionDescription = desc - }) - --- | Define an option of type @'Float'@. This is a simple wrapper around --- 'option'. -floatOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Float -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -floatOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = show def - , optionType = optionTypeFloat - , optionDescription = desc - }) - --- | Define an option of type @'Double'@. This is a simple wrapper around --- 'option'. -doubleOption :: String -- ^ Field name - -> String -- ^ Long flag - -> Double -- ^ Default value - -> String -- ^ Description in @--help@ - -> OptionsM () -doubleOption name flag def desc = option name (\o -> o - { optionLongFlags = [flag] - , optionDefault = show def - , optionType = optionTypeDouble - , optionDescription = desc - }) - --- | Define an option group. --- --- Option groups are used to make long @--help@ output more readable, by --- hiding obscure or rarely-used options from the main summary. --- --- If an option is in a group named @\"examples\"@, it will only be shown --- in the help output if the user provides the flag @--help-examples@ or --- @--help-all@. The flag @--help-all@ will show all options, in all groups. -group :: String -- ^ Group name - -> (Group -> Group) - -> Group -group name f = f (Group - { groupName = Just name - , groupTitle = "" - , groupDescription = "" - }) - --- | See @'parseOptions'@ and @'parseSubcommand'@. -class Parsed a where - parsedError_ :: a -> Maybe String - parsedHelp_ :: a -> String - --- | See @'parseOptions'@. -data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String] - --- | See @'parseSubcommand'@. -data ParsedSubcommand action = ParsedSubcommand (Maybe action) (Maybe String) String - -instance Parsed (ParsedOptions a) where - parsedError_ (ParsedOptions _ x _ _) = x - parsedHelp_ (ParsedOptions _ _ x _) = x - -instance Parsed (ParsedSubcommand a) where - parsedError_ (ParsedSubcommand _ x _) = x - parsedHelp_ (ParsedSubcommand _ _ x) = x - --- | Get the options value that was parsed from argv, or @Nothing@ if the --- arguments could not be converted into options. --- --- Note: This function return @Nothing@ if the user provided a help flag. To --- check whether an error occured during parsing, check the value of --- @'parsedError'@. -parsedOptions :: ParsedOptions opts -> Maybe opts -parsedOptions (ParsedOptions x _ _ _) = x - --- | Get command-line arguments remaining after parsing options. The arguments --- are unchanged from the original argument list, and have not been decoded --- or otherwise transformed. -parsedArguments :: ParsedOptions opts -> [String] -parsedArguments (ParsedOptions _ _ _ x) = x - --- | Get the subcommand action that was parsed from argv, or @Nothing@ if the --- arguments could not be converted into a valid action. --- --- Note: This function return @Nothing@ if the user provided a help flag. To --- check whether an error occured during parsing, check the value of --- @'parsedError'@. -parsedSubcommand :: ParsedSubcommand action -> Maybe action -parsedSubcommand (ParsedSubcommand x _ _) = x - --- | Get the error that prevented options from being parsed from argv, --- or @Nothing@ if no error was detected. -parsedError :: Parsed a => a -> Maybe String -parsedError = parsedError_ - --- | Get a help message to show the user. If the arguments included --- a help flag, this will be a message appropriate to that flag. --- Otherwise, it is a summary (equivalent to @--help@). --- --- This is always a non-empty string, regardless of whether the parse --- succeeded or failed. If you need to perform additional validation --- on the options value, this message can be displayed if validation --- fails. -parsedHelp :: Parsed a => a -> String -parsedHelp = parsedHelp_ - --- | Attempt to convert a list of command-line arguments into an options --- value. This can be used by application developers who want finer control --- over error handling, or who want to perform additional validation on the --- options value. --- --- The argument list must be in the same encoding as the result of --- 'System.Environment.getArgs'. --- --- Use @'parsedOptions'@, @'parsedArguments'@, @'parsedError'@, and --- @'parsedHelp'@ to inspect the result of @'parseOptions'@. --- --- Example: --- --- @ ---getOptionsOrDie :: Options a => IO a ---getOptionsOrDie = do --- argv <- System.Environment.getArgs --- let parsed = 'parseOptions' argv --- case 'parsedOptions' parsed of --- Just opts -> return opts --- Nothing -> case 'parsedError' parsed of --- Just err -> do --- hPutStrLn stderr ('parsedHelp' parsed) --- hPutStrLn stderr err --- exitFailure --- Nothing -> do --- hPutStr stdout ('parsedHelp' parsed) --- exitSuccess --- @ -parseOptions :: Options opts => [String] -> ParsedOptions opts -parseOptions argv = parsed where - defs = addHelpFlags optionsDefs - help flag = helpFor flag defs Nothing - parsed = case tokenize defs argv of - (_, Left err) -> ParsedOptions Nothing (Just err) (help HelpSummary) [] - (_, Right tokens) -> case checkHelpFlag tokens of - Just helpFlag -> ParsedOptions Nothing Nothing (help helpFlag) [] - Nothing -> case optionsParse tokens of - Left err -> ParsedOptions Nothing (Just err) (help HelpSummary) [] - Right (opts, args) -> ParsedOptions (Just opts) Nothing (help HelpSummary) args - --- | Retrieve 'System.Environment.getArgs', and attempt to parse it into a --- valid value of an 'Options' type plus a list of left-over arguments. The --- options and arguments are then passed to the provided computation. --- --- If parsing fails, this computation will print an error and call --- 'exitFailure'. --- --- If parsing succeeds, and the user has passed a @--help@ flag, and the --- developer is using the default help flag definitions, then this computation --- will print documentation and call 'exitSuccess'. --- --- See 'runSubcommand' for details on subcommand support. -runCommand :: (MonadIO m, Options opts) => (opts -> [String] -> m a) -> m a -runCommand io = do - argv <- liftIO System.Environment.getArgs - let parsed = parseOptions argv - case parsedOptions parsed of - Just opts -> io opts (parsedArguments parsed) - Nothing -> liftIO $ case parsedError parsed of - Just err -> do - hPutStrLn stderr (parsedHelp parsed) - hPutStrLn stderr err - exitFailure - Nothing -> do - hPutStr stdout (parsedHelp parsed) - exitSuccess - -data Subcommand cmdOpts action = Subcommand String [OptionInfo] (TokensFor cmdOpts -> Either String action) - -subcommand :: (Options cmdOpts, Options subcmdOpts) - => String -- ^ The subcommand name. - -> (cmdOpts -> subcmdOpts -> [String] -> action) -- ^ The action to run. - -> Subcommand cmdOpts action -subcommand name fn = Subcommand name opts checkTokens where - opts = optInfosFromOptType fn optionsDefs - - optInfosFromOptType :: Options subcmdOpts => (cmdOpts -> subcmdOpts -> [String] -> action) -> OptionDefinitions subcmdOpts -> [OptionInfo] - optInfosFromOptType _ (OptionDefinitions infos _) = infos - - checkTokens tokens = case optionsParse' tokens of - Left err -> Left err - Right cmdOpts -> case optionsParse (castTokens tokens) of - Left err -> Left err - Right (subcmdOpts, args) -> Right (fn cmdOpts subcmdOpts args) - -subcommandInfo :: Subcommand cmdOpts action -> (String, [OptionInfo]) -subcommandInfo (Subcommand name opts _) = (name, opts) - -addSubcommands :: [Subcommand cmdOpts action] -> OptionDefinitions cmdOpts -> OptionDefinitions cmdOpts -addSubcommands subcommands defs = case defs of - OptionDefinitions mainOpts subcmdOpts -> OptionDefinitions mainOpts (subcmdOpts ++ map subcommandInfo subcommands) - -findSubcmd :: [Subcommand cmdOpts action] -> String -> TokensFor cmdOpts -> Either String action -findSubcmd subcommands name tokens = subcmd where - asoc = [(n, cmd) | cmd@(Subcommand n _ _) <- subcommands] - subcmd = case lookup name asoc of - Nothing -> Left ("Unknown subcommand " ++ show name ++ ".") - Just (Subcommand _ _ checkTokens) -> checkTokens tokens - --- | Attempt to convert a list of command-line arguments into a subcommand --- action. This can be used by application developers who want finer control --- over error handling, or who want subcommands that run in an unusual monad. --- --- The argument list must be in the same encoding as the result of --- 'System.Environment.getArgs'. --- --- Use @'parsedSubcommand'@, @'parsedError'@, and @'parsedHelp'@ to inspect the --- result of @'parseSubcommand'@. --- --- Example: --- --- @ ---runSubcommand :: Options cmdOpts => [Subcommand cmdOpts (IO a)] -> IO a ---runSubcommand subcommands = do --- argv <- System.Environment.getArgs --- let parsed = 'parseSubcommand' subcommands argv --- case 'parsedSubcommand' parsed of --- Just cmd -> cmd --- Nothing -> case 'parsedError' parsed of --- Just err -> do --- hPutStrLn stderr ('parsedHelp' parsed) --- hPutStrLn stderr err --- exitFailure --- Nothing -> do --- hPutStr stdout ('parsedHelp' parsed) --- exitSuccess --- @ --- -parseSubcommand :: Options cmdOpts => [Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action -parseSubcommand subcommands argv = parsed where - defs = addHelpFlags (addSubcommands subcommands optionsDefs) - help flag = helpFor flag defs - parsed = case tokenize defs argv of - (subcmd, Left err) -> ParsedSubcommand Nothing (Just err) (help HelpSummary subcmd) - (Nothing, Right tokens) -> case checkHelpFlag tokens of - Just helpFlag -> ParsedSubcommand Nothing Nothing (help helpFlag Nothing) - Nothing -> ParsedSubcommand Nothing (Just "No subcommand specified") (help HelpSummary Nothing) - (Just subcmdName, Right tokens) -> case findSubcmd subcommands subcmdName tokens of - Left err -> ParsedSubcommand Nothing (Just err) (help HelpSummary (Just subcmdName)) - Right io -> case checkHelpFlag tokens of - Just helpFlag -> ParsedSubcommand Nothing Nothing (help helpFlag (Just subcmdName)) - Nothing -> ParsedSubcommand (Just io) Nothing (help HelpSummary (Just subcmdName)) - --- | Used to run applications that are split into subcommands. --- --- Use 'subcommand' to define available commands and their actions, then pass --- them to this computation to select one and run it. If the user specifies --- an invalid subcommand, this computation will print an error and call --- 'exitFailure'. In handling of invalid flags or @--help@, 'runSubcommand' --- acts like 'runCommand'. --- --- @ ---{-\# LANGUAGE TemplateHaskell \#-} --- ---import Control.Monad (unless) ---import Options --- ---'defineOptions' \"MainOptions\" $ do --- 'boolOption' \"optQuiet\" \"quiet\" False \"Whether to be quiet.\" --- ---'defineOptions' \"HelloOpts\" $ do --- 'stringOption' \"optHello\" \"hello\" \"Hello!\" \"How to say hello.\" --- ---'defineOptions' \"ByeOpts\" $ do --- 'stringOption' \"optName\" \"name\" \"\" \"The user's name.\" --- ---hello :: MainOptions -> HelloOpts -> [String] -> IO () ---hello mainOpts opts args = unless (optQuiet mainOpts) $ do --- putStrLn (optHello opts) --- ---bye :: MainOptions -> ByeOpts -> [String] -> IO () ---bye mainOpts opts args = unless (optQuiet mainOpts) $ do --- putStrLn (\"Good bye \" ++ optName opts) --- ---main :: IO () ---main = 'runSubcommand' --- [ 'subcommand' \"hello\" hello --- , 'subcommand' \"bye\" bye --- ] --- @ --- --- >$ ./app hello --- >Hello! --- >$ ./app hello --hello='Allo!' --- >Allo! --- >$ ./app bye --- >Good bye --- >$ ./app bye --name='John' --- >Good bye John +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module: Options +-- License: MIT +-- +-- The @options@ package lets library and application developers easily work +-- with command-line options. +-- +-- The following example is a full program that can accept two options, +-- @--message@ and @--quiet@: +-- +-- @ +--import Control.Applicative +--import Options +-- +--data MainOptions = MainOptions +-- { optMessage :: String +-- , optQuiet :: Bool +-- } +-- +--instance 'Options' MainOptions where +-- 'defineOptions' = pure MainOptions +-- \<*\> 'simpleOption' \"message\" \"Hello world!\" +-- \"A message to show the user.\" +-- \<*\> 'simpleOption' \"quiet\" False +-- \"Whether to be quiet.\" +-- +--main :: IO () +--main = 'runCommand' $ \\opts args -> do +-- if optQuiet opts +-- then return () +-- else putStrLn (optMessage opts) +-- @ +-- +-- >$ ./hello +-- >Hello world! +-- >$ ./hello --message='ciao mondo' +-- >ciao mondo +-- >$ ./hello --quiet +-- >$ +-- +-- In addition, this library will automatically create documentation options +-- such as @--help@ and @--help-all@: +-- +-- >$ ./hello --help +-- >Help Options: +-- > -h, --help +-- > Show option summary. +-- > --help-all +-- > Show all help options. +-- > +-- >Application Options: +-- > --message :: text +-- > A message to show the user. +-- > default: "Hello world!" +-- > --quiet :: bool +-- > Whether to be quiet. +-- > default: false +module Options + ( + -- * Defining options + Options(..) + , defaultOptions + , simpleOption + , DefineOptions + , SimpleOptionType(..) + + -- * Defining subcommands + , Subcommand + , subcommand + + -- * Running main with options + , runCommand + , runSubcommand + + -- * Parsing argument lists + , Parsed + , parsedError + , parsedHelp + + -- ** Parsing options + , ParsedOptions + , parsedOptions + , parsedArguments + , parseOptions + + -- ** Parsing sub-commands + , ParsedSubcommand + , parsedSubcommand + , parseSubcommand + + -- * Advanced option definitions + , OptionType + , defineOption + , Option + , optionShortFlags + , optionLongFlags + , optionDefault + , optionDescription + , optionGroup + + -- ** Option groups + , Group + , groupName + , groupTitle + , groupDescription + + -- * Option types + , optionType_bool + + , optionType_string + + , optionType_int + , optionType_int8 + , optionType_int16 + , optionType_int32 + , optionType_int64 + , optionType_word + , optionType_word8 + , optionType_word16 + , optionType_word32 + , optionType_word64 + , optionType_integer + + , optionType_float + , optionType_double + + , optionType_maybe + , optionType_list + , optionType_set + , optionType_map + , optionType_enum + + -- ** Custom option types + , optionType + , optionTypeName + , optionTypeDefault + , optionTypeParse + , optionTypeShow + , optionTypeUnary + ) where + +import Control.Applicative +import Control.Monad.IO.Class (liftIO, MonadIO) +import Data.Int +import Data.List (intercalate) +import qualified Data.Map as Map +import Data.Maybe (isJust) +import qualified Data.Set as Set +import Data.Word +import qualified System.Environment +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, hPutStrLn, stderr, stdout) + +import Options.Help +import Options.Tokenize +import Options.Types + +-- | Options are defined together in a single data type, which will be an +-- instance of 'Options'. +-- +-- See 'defineOptions' for details on defining instances of 'Options'. +class Options opts where + -- | Defines the structure and metadata of the options in this type, + -- including their types, flag names, and documentation. + -- + -- Options with a basic type and a single flag name may be defined + -- with 'simpleOption'. Options with more complex requirements may + -- be defined with 'defineOption'. + -- + -- Non-option fields in the type may be set using applicative functions + -- such as 'pure'. + -- + -- Options may be included from another type by using a nested call to + -- 'defineOptions'. + -- + -- Library authors are encouraged to aggregate their options into a + -- few top-level types, so application authors can include it + -- easily in their own option definitions. + defineOptions :: DefineOptions opts + +data DefineOptions a = DefineOptions a (Integer -> (Integer, [OptionInfo])) (Integer -> Map.Map OptionKey Token -> Either String (Integer, a)) + +instance Functor DefineOptions where + fmap fn (DefineOptions defaultValue getInfo parse) = DefineOptions (fn defaultValue) getInfo (\key tokens -> case parse key tokens of + Left err -> Left err + Right (key', a) -> Right (key', fn a)) + +instance Applicative DefineOptions where + pure a = DefineOptions a (\key -> (key, [])) (\key _ -> Right (key, a)) + (DefineOptions acc_default acc_getInfo acc_parse) <*> (DefineOptions defaultValue getInfo parse) = DefineOptions + (acc_default defaultValue) + (\key -> case acc_getInfo key of + (key', infos) -> case getInfo key' of + (key'', infos') -> (key'', infos ++ infos')) + (\key tokens -> case acc_parse key tokens of + Left err -> Left err + Right (key', fn) -> case parse key' tokens of + Left err -> Left err + Right (key'', a) -> Right (key'', fn a)) + +-- | An options value containing only the default values for each option. +-- This is equivalent to the options value when parsing an empty argument +-- list. +defaultOptions :: Options opts => opts +defaultOptions = case defineOptions of + (DefineOptions def _ _) -> def + +-- | An option's type determines how the option will be parsed, and which +-- Haskell type the parsed value will be stored as. There are many types +-- available, covering most basic types and a few more advanced types. +data OptionType val = OptionType + { + -- | The name of this option type; used in @--help@ output. + optionTypeName :: String + + -- | The default value for options of this type. This will be used + -- if 'optionDefault' is not set when defining the option. + , optionTypeDefault :: val + + -- | Try to parse the given string to an option value. If parsing + -- fails, an error message will be returned. + , optionTypeParse :: String -> Either String val + + -- | Format the value for display; used in @--help@ output. + , optionTypeShow :: val -> String + + -- | If not Nothing, then options of this type may be set by a unary + -- flag. The option will be parsed as if the given value were set. + , optionTypeUnary :: Maybe val + } + +-- | Define a new option type with the given name, default, and behavior. +optionType :: String -- ^ Name + -> val -- ^ Default value + -> (String -> Either String val) -- ^ Parser + -> (val -> String) -- ^ Formatter + -> OptionType val +optionType name def parse show' = OptionType name def parse show' Nothing + +class SimpleOptionType a where + simpleOptionType :: OptionType a + +instance SimpleOptionType Bool where + simpleOptionType = optionType_bool + +-- | Store an option as a @'Bool'@. The option's value must be either +-- @\"true\"@ or @\"false\"@. +-- +-- Boolean options are unary, which means that their value is optional when +-- specified on the command line. If a flag is present, the option is set to +-- True. +-- +-- >$ ./app -q +-- >$ ./app --quiet +-- +-- Boolean options may still be specified explicitly by using long flags with +-- the @--flag=value@ format. This is the only way to set a unary flag to +-- @\"false\"@. +-- +-- >$ ./app --quiet=true +-- >$ ./app --quiet=false +optionType_bool :: OptionType Bool +optionType_bool = (optionType "bool" False parseBool (\x -> if x then "true" else "false")) + { optionTypeUnary = Just True + } + +parseBool :: String -> Either String Bool +parseBool s = case s of + "true" -> Right True + "false" -> Right False + _ -> Left (show s ++ " is not in {\"true\", \"false\"}.") + +instance SimpleOptionType String where + simpleOptionType = optionType_string + +-- | Store an option value as a @'String'@. The value is decoded to Unicode +-- first, if needed. The value may contain non-Unicode bytes, in which case +-- they will be stored using GHC 7.4's encoding for mixed-use strings. +optionType_string :: OptionType String +optionType_string = optionType "text" "" Right show + +instance SimpleOptionType Integer where + simpleOptionType = optionType_integer + +-- | Store an option as an @'Integer'@. The option value must be an integer. +-- There is no minimum or maximum value. +optionType_integer :: OptionType Integer +optionType_integer = optionType "integer" 0 parseInteger show + +parseInteger :: String -> Either String Integer +parseInteger s = parsed where + parsed = if valid + then Right (read s) + else Left (show s ++ " is not an integer.") + valid = case s of + [] -> False + '-':s' -> allDigits s' + _ -> allDigits s + allDigits = all (\c -> c >= '0' && c <= '9') + +parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a +parseBoundedIntegral label = parse where + getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer) + getBounds _ min' max' = (toInteger min', toInteger max') + + (minInt, maxInt) = getBounds parse minBound maxBound + + parse s = case parseInteger s of + Left err -> Left err + Right int -> if int < minInt || int > maxInt + then Left (show int ++ " is not within bounds [" ++ show minInt ++ ":" ++ show maxInt ++ "] of type " ++ label ++ ".") + else Right (fromInteger int) + +optionTypeBoundedInt :: (Bounded a, Integral a, Show a) => String -> OptionType a +optionTypeBoundedInt tName = optionType tName 0 (parseBoundedIntegral tName) show + +instance SimpleOptionType Int where + simpleOptionType = optionType_int + +-- | Store an option as an @'Int'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionType_int :: OptionType Int +optionType_int = optionTypeBoundedInt "int" + +instance SimpleOptionType Int8 where + simpleOptionType = optionType_int8 + +-- | Store an option as an @'Int8'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionType_int8 :: OptionType Int8 +optionType_int8 = optionTypeBoundedInt "int8" + +instance SimpleOptionType Int16 where + simpleOptionType = optionType_int16 + +-- | Store an option as an @'Int16'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionType_int16 :: OptionType Int16 +optionType_int16 = optionTypeBoundedInt "int16" + +instance SimpleOptionType Int32 where + simpleOptionType = optionType_int32 + +-- | Store an option as an @'Int32'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionType_int32 :: OptionType Int32 +optionType_int32 = optionTypeBoundedInt "int32" + +instance SimpleOptionType Int64 where + simpleOptionType = optionType_int64 + +-- | Store an option as an @'Int64'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionType_int64 :: OptionType Int64 +optionType_int64 = optionTypeBoundedInt "int64" + +instance SimpleOptionType Word where + simpleOptionType = optionType_word + +-- | Store an option as a @'Word'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionType_word :: OptionType Word +optionType_word = optionTypeBoundedInt "uint" + +instance SimpleOptionType Word8 where + simpleOptionType = optionType_word8 + +-- | Store an option as a @'Word8'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionType_word8 :: OptionType Word8 +optionType_word8 = optionTypeBoundedInt "uint8" + +instance SimpleOptionType Word16 where + simpleOptionType = optionType_word16 + +-- | Store an option as a @'Word16'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionType_word16 :: OptionType Word16 +optionType_word16 = optionTypeBoundedInt "uint16" + +instance SimpleOptionType Word32 where + simpleOptionType = optionType_word32 + +-- | Store an option as a @'Word32'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionType_word32 :: OptionType Word32 +optionType_word32 = optionTypeBoundedInt "uint32" + +instance SimpleOptionType Word64 where + simpleOptionType = optionType_word64 + +-- | Store an option as a @'Word64'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionType_word64 :: OptionType Word64 +optionType_word64 = optionTypeBoundedInt "uint64" + +instance SimpleOptionType Float where + simpleOptionType = optionType_float + +-- | Store an option as a @'Float'@. The option value must be a number. Due to +-- the imprecision of floating-point math, the stored value might not exactly +-- match the user's input. If the user's input is out of range for the +-- @'Float'@ type, it will be stored as @Infinity@ or @-Infinity@. +optionType_float :: OptionType Float +optionType_float = optionType "float32" 0 parseFloat show + +instance SimpleOptionType Double where + simpleOptionType = optionType_double + +-- | Store an option as a @'Double'@. The option value must be a number. Due to +-- the imprecision of floating-point math, the stored value might not exactly +-- match the user's input. If the user's input is out of range for the +-- @'Double'@ type, it will be stored as @Infinity@ or @-Infinity@. +optionType_double :: OptionType Double +optionType_double = optionType "float64" 0 parseFloat show + +parseFloat :: Read a => String -> Either String a +parseFloat s = case reads s of + [(x, "")] -> Right x + _ -> Left (show s ++ " is not a number.") + +instance SimpleOptionType a => SimpleOptionType (Maybe a) where + simpleOptionType = optionType_maybe simpleOptionType + +-- | Store an option as a @'Maybe'@ of another type. The value will be +-- @Nothing@ if the option is set to an empty string. +optionType_maybe :: OptionType a -> OptionType (Maybe a) +optionType_maybe t = maybeT { optionTypeUnary = unary } where + maybeT = optionType name Nothing (parseMaybe t) (showMaybe t) + name = "maybe<" ++ optionTypeName t ++ ">" + unary = case optionTypeUnary t of + Nothing -> Nothing + Just val -> Just (Just val) + +parseMaybe :: OptionType val -> String -> Either String (Maybe val) +parseMaybe t s = case s of + "" -> Right Nothing + _ -> case optionTypeParse t s of + Left err -> Left err + Right a -> Right (Just a) + +showMaybe :: OptionType val -> Maybe val -> String +showMaybe _ Nothing = "" +showMaybe t (Just x) = optionTypeShow t x + +-- | Store an option as a @'Set.Set'@, using another option type for the +-- elements. The separator should be a character that will not occur within +-- the values, such as a comma or semicolon. +-- +-- Duplicate elements in the input are permitted. +optionType_set :: Ord a + => Char -- ^ Element separator + -> OptionType a -- ^ Element type + -> OptionType (Set.Set a) +optionType_set sep t = optionType name Set.empty parseSet showSet where + name = "set<" ++ optionTypeName t ++ ">" + parseSet s = case parseList (optionTypeParse t) (split sep s) of + Left err -> Left err + Right xs -> Right (Set.fromList xs) + showSet xs = intercalate [sep] (map (optionTypeShow t) (Set.toList xs)) + +-- | Store an option as a 'Map.Map', using other option types for the keys and +-- values. +-- +-- The item separator is used to separate key/value pairs from eachother. It +-- should be a character that will not occur within either the keys or values. +-- +-- The value separator is used to separate the key from the value. It should +-- be a character that will not occur within the keys. It may occur within the +-- values. +-- +-- Duplicate keys in the input are permitted. The final value for each key is +-- stored. +optionType_map :: Ord k + => Char -- ^ Item separator + -> Char -- ^ Key/Value separator + -> OptionType k -- ^ Key type + -> OptionType v -- ^ Value type + -> OptionType (Map.Map k v) +optionType_map itemSep keySep kt vt = optionType name Map.empty parser showMap where + name = "map<" ++ optionTypeName kt ++ "," ++ optionTypeName vt ++ ">" + parser s = parseMap keySep (optionTypeParse kt) (optionTypeParse vt) (split itemSep s) + showMap m = intercalate [itemSep] (map showItem (Map.toList m)) + showItem (k, v) = optionTypeShow kt k ++ [keySep] ++ optionTypeShow vt v + +parseList :: (String -> Either String a) -> [String] -> Either String [a] +parseList p = loop where + loop [] = Right [] + loop (x:xs) = case p x of + Left err -> Left err + Right v -> case loop xs of + Left err -> Left err + Right vs -> Right (v:vs) + +parseMap :: Ord k => Char -> (String -> Either String k) -> (String -> Either String v) -> [String] -> Either String (Map.Map k v) +parseMap keySep pKey pVal = parsed where + parsed strs = case parseList pItem strs of + Left err -> Left err + Right xs -> Right (Map.fromList xs) + pItem s = case break (== keySep) s of + (sKey, valAndSep) -> case valAndSep of + [] -> Left ("Map item " ++ show s ++ " has no value.") + _ : sVal -> case pKey sKey of + Left err -> Left err + Right key -> case pVal sVal of + Left err -> Left err + Right val -> Right (key, val) + +split :: Char -> String -> [String] +split _ [] = [] +split sep s0 = loop s0 where + loop s = let + (chunk, rest) = break (== sep) s + cont = chunk : loop (tail rest) + in if null rest then [chunk] else cont + +-- | Store an option as a list, using another option type for the elements. +-- The separator should be a character that will not occur within the values, +-- such as a comma or semicolon. +optionType_list :: Char -- ^ Element separator + -> OptionType a -- ^ Element type + -> OptionType [a] +optionType_list sep t = optionType name [] parser shower where + name = "list<" ++ optionTypeName t ++ ">" + parser s = parseList (optionTypeParse t) (split sep s) + shower xs = intercalate [sep] (map (optionTypeShow t) xs) + +-- | Store an option as one of a set of possible values. The type must be a +-- bounded enumeration, and the type's 'Show' instance will be used to +-- implement the parser. +-- +-- This is a simplistic implementation, useful for quick scripts. Users with +-- more complex requirements for enum parsing are encouraged to define their +-- own option types using 'optionType'. +-- +-- @ +--data Action = Hello | Goodbye +-- deriving (Bounded, Enum, Show) +-- +--data MainOptions = MainOptions { optAction :: Action } +-- +--instance 'Options' MainOptions where +-- 'defineOptions' = pure MainOptions +-- \<*\> 'defineOption' (optionType_enum \"action\") (\\o -> o +-- { 'optionLongFlags' = [\"action\"] +-- , 'optionDefault' = Hello +-- }) +-- +--main = 'runCommand' $ \\opts args -> do +-- putStrLn (\"Running action \" ++ show (optAction opts)) +-- @ +-- +-- >$ ./app +-- >Running action Hello +-- >$ ./app --action=Goodbye +-- >Running action Goodbye +optionType_enum :: (Bounded a, Enum a, Show a) + => String -- ^ Option type name + -> OptionType a +optionType_enum tName = optionType tName minBound parseEnum show where + values = Map.fromList [(show x, x) | x <- enumFrom minBound] + setString = "{" ++ intercalate ", " (map show (Map.keys values)) ++ "}" + parseEnum s = case Map.lookup s values of + Nothing -> Left (show s ++ " is not in " ++ setString ++ ".") + Just x -> Right x + +-- | Defines a new option in the current options type. +-- +simpleOption :: SimpleOptionType a + => String -- long flag + -> a -- default value + -> String -- description + -> DefineOptions a +simpleOption flag def desc = defineOption simpleOptionType (\o -> o + { optionLongFlags = [flag] + , optionDefault = def + , optionDescription = desc + }) + +-- | Defines a new option in the current options type. +-- +-- All options must have one or more /flags/. Options may also have a +-- default value, a description, and a group. +-- +-- The /flags/ are how the user specifies an option on the command line. Flags +-- may be /short/ or /long/. See 'optionShortFlags' and 'optionLongFlags' for +-- details. +-- +-- @ +--'defineOption' 'optionType_word16' (\\o -> o +-- { 'optionLongFlags' = [\"port\"] +-- , 'optionDefault' = 80 +-- }) +-- @ +defineOption :: OptionType a -> (Option a -> Option a) -> DefineOptions a +defineOption t fn = DefineOptions (optionDefault opt) getInfo parser where + opt = fn (Option + { optionShortFlags = [] + , optionLongFlags = [] + , optionDefault = optionTypeDefault t + , optionDescription = "" + , optionGroup = Nothing + , optionLocation = Nothing + }) + + getInfo key = (key+1, [OptionInfo + { optionInfoKey = OptionKeyGenerated key + , optionInfoShortFlags = optionShortFlags opt + , optionInfoLongFlags = optionLongFlags opt + , optionInfoDefault = optionTypeShow t (optionDefault opt) + , optionInfoDescription = optionDescription opt + , optionInfoGroup = optionGroup opt + , optionInfoLocation = optionLocation opt + , optionInfoTypeName = optionTypeName t + , optionInfoUnary = isJust (optionTypeUnary t) + , optionInfoUnaryOnly = False + }]) + + parser key tokens = case Map.lookup (OptionKeyGenerated key) tokens of + Nothing -> Right (key+1, optionDefault opt) + Just tok -> case tok of + TokenUnary flagName -> case optionTypeUnary t of + Nothing -> Left ("The flag " ++ flagName ++ " requires an argument.") + Just val -> Right (key+1, val) + Token flagName rawValue -> case optionTypeParse t rawValue of + Left err -> Left ("Value for flag " ++ flagName ++ " is invalid: " ++ err) + Right val -> Right (key+1, val) + +data Option a = Option + { + -- | Short flags are a single character. When entered by a user, + -- they are preceded by a dash and possibly other short flags. + -- + -- Short flags must be a letter or a number. + -- + -- Example: An option with @optionShortFlags = [\'p\']@ may be set using: + -- + -- >$ ./app -p 443 + -- >$ ./app -p443 + optionShortFlags :: [Char] + + -- | Long flags are multiple characters. When entered by a user, they + -- are preceded by two dashes. + -- + -- Long flags may contain letters, numbers, @\'-\'@, and @\'_\'@. + -- + -- Example: An option with @optionLongFlags = [\"port\"]@ may be set using: + -- + -- >$ ./app --port 443 + -- >$ ./app --port=443 + , optionLongFlags :: [String] + + -- | Options may have a default value. This will be parsed as if the + -- user had entered it on the command line. + , optionDefault :: a + + -- | An option's description is used with the default implementation + -- of @--help@. It should be a short string describing what the option + -- does. + , optionDescription :: String + + -- | Which group the option is in. See the \"Option groups\" section + -- for details. + , optionGroup :: Maybe Group + + -- | TODO docs + , optionLocation :: Maybe Location + } + +-- * Each option defines at least one short or long flag. +-- * There are no duplicate short or long flags, except between subcommands. +-- * All short or long flags have a reasonable name. +-- * All subcommands have unique names. +validateOptionDefs :: [OptionInfo] -> [(String, [OptionInfo])] -> Either String OptionDefinitions +validateOptionDefs cmdInfos subInfos = Right (addHelpFlags (OptionDefinitions cmdInfos subInfos)) -- TODO + +-- | See @'parseOptions'@ and @'parseSubcommand'@. +class Parsed a where + parsedError_ :: a -> Maybe String + parsedHelp_ :: a -> String + +-- | See @'parseOptions'@. +data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String] + +-- | See @'parseSubcommand'@. +data ParsedSubcommand action = ParsedSubcommand (Maybe action) (Maybe String) String + +instance Parsed (ParsedOptions a) where + parsedError_ (ParsedOptions _ x _ _) = x + parsedHelp_ (ParsedOptions _ _ x _) = x + +instance Parsed (ParsedSubcommand a) where + parsedError_ (ParsedSubcommand _ x _) = x + parsedHelp_ (ParsedSubcommand _ _ x) = x + +-- | Get the options value that was parsed from argv, or @Nothing@ if the +-- arguments could not be converted into options. +-- +-- Note: This function return @Nothing@ if the user provided a help flag. To +-- check whether an error occured during parsing, check the value of +-- @'parsedError'@. +parsedOptions :: ParsedOptions opts -> Maybe opts +parsedOptions (ParsedOptions x _ _ _) = x + +-- | Get command-line arguments remaining after parsing options. The arguments +-- are unchanged from the original argument list, and have not been decoded +-- or otherwise transformed. +parsedArguments :: ParsedOptions opts -> [String] +parsedArguments (ParsedOptions _ _ _ x) = x + +-- | Get the subcommand action that was parsed from argv, or @Nothing@ if the +-- arguments could not be converted into a valid action. +-- +-- Note: This function return @Nothing@ if the user provided a help flag. To +-- check whether an error occured during parsing, check the value of +-- @'parsedError'@. +parsedSubcommand :: ParsedSubcommand action -> Maybe action +parsedSubcommand (ParsedSubcommand x _ _) = x + +-- | Get the error that prevented options from being parsed from argv, +-- or @Nothing@ if no error was detected. +parsedError :: Parsed a => a -> Maybe String +parsedError = parsedError_ + +-- | Get a help message to show the user. If the arguments included +-- a help flag, this will be a message appropriate to that flag. +-- Otherwise, it is a summary (equivalent to @--help@). +-- +-- This is always a non-empty string, regardless of whether the parse +-- succeeded or failed. If you need to perform additional validation +-- on the options value, this message can be displayed if validation +-- fails. +parsedHelp :: Parsed a => a -> String +parsedHelp = parsedHelp_ + +-- | Attempt to convert a list of command-line arguments into an options +-- value. This can be used by application developers who want finer control +-- over error handling, or who want to perform additional validation on the +-- options value. +-- +-- The argument list must be in the same encoding as the result of +-- 'System.Environment.getArgs'. +-- +-- Use @'parsedOptions'@, @'parsedArguments'@, @'parsedError'@, and +-- @'parsedHelp'@ to inspect the result of @'parseOptions'@. +-- +-- Example: +-- +-- @ +--getOptionsOrDie :: Options a => IO a +--getOptionsOrDie = do +-- argv <- System.Environment.getArgs +-- let parsed = 'parseOptions' argv +-- case 'parsedOptions' parsed of +-- Just opts -> return opts +-- Nothing -> case 'parsedError' parsed of +-- Just err -> do +-- hPutStrLn stderr ('parsedHelp' parsed) +-- hPutStrLn stderr err +-- exitFailure +-- Nothing -> do +-- hPutStr stdout ('parsedHelp' parsed) +-- exitSuccess +-- @ +parseOptions :: Options opts => [String] -> ParsedOptions opts +parseOptions argv = parsed where + (DefineOptions _ getInfos parser) = defineOptions + (_, optionInfos) = getInfos 0 + parseTokens = parser 0 + + parsed = case validateOptionDefs optionInfos [] of + Left err -> ParsedOptions Nothing (Just err) "" [] + Right optionDefs -> case tokenize (addHelpFlags optionDefs) argv of + (_, Left err) -> ParsedOptions Nothing (Just err) (helpFor HelpSummary optionDefs Nothing) [] + (_, Right tokens) -> case checkHelpFlag tokens of + Just helpFlag -> ParsedOptions Nothing Nothing (helpFor helpFlag optionDefs Nothing) [] + Nothing -> case parseTokens (tokensMap tokens) of + Left err -> ParsedOptions Nothing (Just err) (helpFor HelpSummary optionDefs Nothing) [] + Right (_, opts) -> ParsedOptions (Just opts) Nothing (helpFor HelpSummary optionDefs Nothing) (tokensArgv tokens) + +-- | Retrieve 'System.Environment.getArgs', and attempt to parse it into a +-- valid value of an 'Options' type plus a list of left-over arguments. The +-- options and arguments are then passed to the provided computation. +-- +-- If parsing fails, this computation will print an error and call +-- 'exitFailure'. +-- +-- If parsing succeeds, and the user has passed a @--help@ flag, and the +-- developer is using the default help flag definitions, then this computation +-- will print documentation and call 'exitSuccess'. +-- +-- See 'runSubcommand' for details on subcommand support. +runCommand :: (MonadIO m, Options opts) => (opts -> [String] -> m a) -> m a +runCommand io = do + argv <- liftIO System.Environment.getArgs + let parsed = parseOptions argv + case parsedOptions parsed of + Just opts -> io opts (parsedArguments parsed) + Nothing -> liftIO $ case parsedError parsed of + Just err -> do + hPutStrLn stderr (parsedHelp parsed) + hPutStrLn stderr err + exitFailure + Nothing -> do + hPutStr stdout (parsedHelp parsed) + exitSuccess + +data Subcommand cmdOpts action = Subcommand String (Integer -> ([OptionInfo], (cmdOpts -> Tokens -> Either String action), Integer)) + +subcommand :: (Options cmdOpts, Options subcmdOpts) + => String -- ^ The subcommand name. + -> (cmdOpts -> subcmdOpts -> [String] -> action) -- ^ The action to run. + -> Subcommand cmdOpts action +subcommand name fn = Subcommand name (\initialKey -> let + (DefineOptions _ getInfos parser) = defineOptions + (nextKey, optionInfos) = getInfos initialKey + parseTokens = parser initialKey + + runAction cmdOpts tokens = case parseTokens (tokensMap tokens) of + Left err -> Left err + Right (_, subOpts) -> Right (fn cmdOpts subOpts (tokensArgv tokens)) + in (optionInfos, runAction, nextKey)) + +-- | Attempt to convert a list of command-line arguments into a subcommand +-- action. This can be used by application developers who want finer control +-- over error handling, or who want subcommands that run in an unusual monad. +-- +-- The argument list must be in the same encoding as the result of +-- 'System.Environment.getArgs'. +-- +-- Use @'parsedSubcommand'@, @'parsedError'@, and @'parsedHelp'@ to inspect the +-- result of @'parseSubcommand'@. +-- +-- Example: +-- +-- @ +--runSubcommand :: Options cmdOpts => [Subcommand cmdOpts (IO a)] -> IO a +--runSubcommand subcommands = do +-- argv <- System.Environment.getArgs +-- let parsed = 'parseSubcommand' subcommands argv +-- case 'parsedSubcommand' parsed of +-- Just cmd -> cmd +-- Nothing -> case 'parsedError' parsed of +-- Just err -> do +-- hPutStrLn stderr ('parsedHelp' parsed) +-- hPutStrLn stderr err +-- exitFailure +-- Nothing -> do +-- hPutStr stdout ('parsedHelp' parsed) +-- exitSuccess +-- @ +-- +parseSubcommand :: Options cmdOpts => [Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action +parseSubcommand subcommands argv = parsed where + (DefineOptions _ getInfos parser) = defineOptions + (cmdNextKey, cmdInfos) = getInfos 0 + cmdParseTokens = parser 0 + + subcmdInfos = do + Subcommand name fn <- subcommands + let (infos, _, _) = fn cmdNextKey + return (name, infos) + + subcmdRunners = Map.fromList $ do + Subcommand name fn <- subcommands + let (_, runner, _) = fn cmdNextKey + return (name, runner) + + parsed = case validateOptionDefs cmdInfos subcmdInfos of + Left err -> ParsedSubcommand Nothing (Just err) "" + Right optionDefs -> case tokenize (addHelpFlags optionDefs) argv of + (subcmd, Left err) -> ParsedSubcommand Nothing (Just err) (helpFor HelpSummary optionDefs subcmd) + (subcmd, Right tokens) -> case checkHelpFlag tokens of + Just helpFlag -> ParsedSubcommand Nothing Nothing (helpFor helpFlag optionDefs subcmd) + Nothing -> case findAction tokens subcmd of + Left err -> ParsedSubcommand Nothing (Just err) (helpFor HelpSummary optionDefs subcmd) + Right action -> ParsedSubcommand (Just action) Nothing (helpFor HelpSummary optionDefs subcmd) + + findAction _ Nothing = Left "No subcommand specified" + findAction tokens (Just subcmdName) = case cmdParseTokens (tokensMap tokens) of + Left err -> Left err + Right (_, cmdOpts) -> case Map.lookup subcmdName subcmdRunners of + Nothing -> Left ("Unknown subcommand " ++ show subcmdName ++ ".") + Just getRunner -> case getRunner cmdOpts tokens of + Left err -> Left err + Right action -> Right action + +-- | Used to run applications that are split into subcommands. +-- +-- Use 'subcommand' to define available commands and their actions, then pass +-- them to this computation to select one and run it. If the user specifies +-- an invalid subcommand, this computation will print an error and call +-- 'exitFailure'. In handling of invalid flags or @--help@, 'runSubcommand' +-- acts like 'runCommand'. +-- +-- @ +--import Control.Applicative +--import Control.Monad (unless) +--import Options +-- +--data MainOptions = MainOptions { optQuiet :: Bool } +--instance 'Options' MainOptions where +-- 'defineOptions' = pure MainOptions +-- \<*\> 'simpleOption' \"quiet\" False \"Whether to be quiet.\" +-- +--data HelloOpts = HelloOpts { optHello :: String } +--instance 'Options' HelloOpts where +-- 'defineOptions' = pure HelloOpts +-- \<*\> 'simpleOption' \"hello\" \"Hello!\" \"How to say hello.\" +-- +--data ByeOpts = ByeOpts { optName :: String } +--instance 'Options' ByeOpts where +-- 'defineOptions' = pure ByeOpts +-- \<*\> 'simpleOption' \"name\" \"\" \"The user's name.\" +-- +--hello :: MainOptions -> HelloOpts -> [String] -> IO () +--hello mainOpts opts args = unless (optQuiet mainOpts) $ do +-- putStrLn (optHello opts) +-- +--bye :: MainOptions -> ByeOpts -> [String] -> IO () +--bye mainOpts opts args = unless (optQuiet mainOpts) $ do +-- putStrLn (\"Good bye \" ++ optName opts) +-- +--main :: IO () +--main = 'runSubcommand' +-- [ 'subcommand' \"hello\" hello +-- , 'subcommand' \"bye\" bye +-- ] +-- @ +-- +-- >$ ./app hello +-- >Hello! +-- >$ ./app hello --hello='Allo!' +-- >Allo! +-- >$ ./app bye +-- >Good bye +-- >$ ./app bye --name='Alice' +-- >Good bye Alice runSubcommand :: (Options opts, MonadIO m) => [Subcommand opts (m a)] -> m a runSubcommand subcommands = do argv <- liftIO System.Environment.getArgs diff --git a/lib/Options/Help.hs b/lib/Options/Help.hs --- a/lib/Options/Help.hs +++ b/lib/Options/Help.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- | -- Module: Options.Help -- License: MIT @@ -11,19 +9,19 @@ ) where import Control.Monad.Writer -import Data.List (intercalate, partition, stripPrefix) -import Data.Maybe (isNothing, listToMaybe, maybeToList) +import Data.Char (isSpace) +import Data.List (intercalate, partition) +import Data.Maybe (isNothing, listToMaybe) import qualified Data.Set as Set import qualified Data.Map as Map -import Language.Haskell.TH (location, loc_package, loc_module) - +import Options.Tokenize import Options.Types data HelpFlag = HelpSummary | HelpAll | HelpGroup String deriving (Eq, Show) -addHelpFlags :: OptionDefinitions a -> OptionDefinitions a +addHelpFlags :: OptionDefinitions -> OptionDefinitions addHelpFlags (OptionDefinitions opts subcmds) = OptionDefinitions withHelp subcmdsWithHelp where shortFlags = Set.fromList $ do opt <- opts @@ -34,30 +32,36 @@ withHelp = optHelpSummary ++ optsGroupHelp ++ opts - groupHelp = GroupInfo - { groupInfoName = "all" - , groupInfoTitle = "Help Options" - , groupInfoDescription = "Show all help options." + groupHelp = Group + { groupName = "all" + , groupTitle = "Help Options" + , groupDescription = "Show all help options." } optSummary = OptionInfo - { optionInfoKey = keyFor "optHelpSummary" + { optionInfoKey = OptionKeyHelpSummary , optionInfoShortFlags = [] , optionInfoLongFlags = [] - , optionInfoDefault = "false" + , optionInfoDefault = "" , optionInfoUnary = True + , optionInfoUnaryOnly = True , optionInfoDescription = "Show option summary." , optionInfoGroup = Just groupHelp + , optionInfoLocation = Nothing + , optionInfoTypeName = "" } optGroupHelp group flag = OptionInfo - { optionInfoKey = keyFor "optHelpGroup" ++ ":" ++ groupInfoName group + { optionInfoKey = OptionKeyHelpGroup (groupName group) , optionInfoShortFlags = [] , optionInfoLongFlags = [flag] - , optionInfoDefault = "false" + , optionInfoDefault = "" , optionInfoUnary = True - , optionInfoDescription = groupInfoDescription group + , optionInfoUnaryOnly = True + , optionInfoDescription = groupDescription group , optionInfoGroup = Just groupHelp + , optionInfoLocation = Nothing + , optionInfoTypeName = "" } optHelpSummary = if Set.member 'h' shortFlags @@ -76,10 +80,10 @@ }] optsGroupHelp = do - let (groupsAndOpts, _) = uniqueGroupInfos opts + let (groupsAndOpts, _) = uniqueGroups opts let groups = [g | (g, _) <- groupsAndOpts] group <- (groupHelp : groups) - let flag = "help-" ++ groupInfoName group + let flag = "help-" ++ groupName group if Set.member flag longFlags then [] else [optGroupHelp group flag] @@ -90,37 +94,32 @@ opt <- subcmdOpts ++ optsGroupHelp optionInfoLongFlags opt - let (groupsAndOpts, _) = uniqueGroupInfos subcmdOpts + let (groupsAndOpts, _) = uniqueGroups subcmdOpts let groups = [g | (g, _) <- groupsAndOpts] let newOpts = do group <- groups - let flag = "help-" ++ groupInfoName group + let flag = "help-" ++ groupName group if Set.member flag (Set.union longFlags subcmdLongFlags) then [] else [optGroupHelp group flag] return (subcmdName, newOpts ++ subcmdOpts) -checkHelpFlag :: TokensFor a -> Maybe HelpFlag -checkHelpFlag (TokensFor tokens _) = flag where +checkHelpFlag :: Tokens -> Maybe HelpFlag +checkHelpFlag tokens = flag where flag = listToMaybe helpKeys helpKeys = do - (k, _) <- tokens - if k == keySummary - then return HelpSummary - else if k == keyAll - then return HelpAll - else do - groupName <- maybeToList (stripPrefix keyGroupPrefix k) - return (HelpGroup groupName) - keySummary = keyFor "optHelpSummary" - keyAll = keyFor "optHelpGroup:all" - keyGroupPrefix = keyFor "optHelpGroup:" + (k, _) <- tokensList tokens + case k of + OptionKeyHelpSummary -> return HelpSummary + OptionKeyHelpGroup "all" -> return HelpAll + OptionKeyHelpGroup name -> return (HelpGroup name) + _ -> [] -helpFor :: HelpFlag -> OptionDefinitions a -> Maybe String -> String +helpFor :: HelpFlag -> OptionDefinitions -> Maybe String -> String helpFor flag defs subcmd = case flag of HelpSummary -> execWriter (showHelpSummary defs subcmd) HelpAll -> execWriter (showHelpAll defs subcmd) - HelpGroup groupName -> execWriter (showHelpOneGroup defs groupName subcmd) + HelpGroup name -> execWriter (showHelpOneGroup defs name subcmd) showOptionHelp :: OptionInfo -> Writer String () showOptionHelp info = do @@ -134,31 +133,52 @@ let optStringCsv = intercalate ", " optStrings tell " " tell optStringCsv - - let desc = optionInfoDescription info - unless (null desc) $ do - if length optStringCsv > 27 - then do - tell "\n" - tell " " - tell (optionInfoDescription info) - else do - tell (replicate (28 - length optStringCsv) ' ') - tell (optionInfoDescription info) - + unless (null (optionInfoTypeName info)) $ do + tell " :: " + tell (optionInfoTypeName info) tell "\n" + unless (null (optionInfoDescription info)) $ do + forM_ (wrapWords 76 (optionInfoDescription info)) $ \line -> do + tell " " + tell line + tell "\n" + unless (null (optionInfoDefault info)) $ do + tell " default: " + tell (optionInfoDefault info) + tell "\n" -showHelpSummary :: OptionDefinitions a -> Maybe String -> Writer String () +-- A simple greedy word-wrapper for fixed-width terminals, permitting overruns +-- and ragged edges. +wrapWords :: Int -> String -> [String] +wrapWords breakWidth = wrap where + wrap line = if length line <= breakWidth + then [line] + else if any isBreak line + then case splitAt breakWidth line of + (beforeBreak, afterBreak) -> case reverseBreak isBreak beforeBreak of + (beforeWrap, afterWrap) -> beforeWrap : wrap (afterWrap ++ afterBreak) + else [line] + isBreak c = case c of + '\xA0' -> False -- NO-BREAK SPACE + '\x202F' -> False -- NARROW NO-BREAK SPACE + '\x2011' -> False -- NON-BREAKING HYPHEN + '-' -> True + _ -> isSpace c + reverseBreak :: (a -> Bool) -> [a] -> ([a], [a]) + reverseBreak f xs = case break f (reverse xs) of + (after, before) -> (reverse before, reverse after) + +showHelpSummary :: OptionDefinitions -> Maybe String -> Writer String () showHelpSummary (OptionDefinitions mainOpts subcmds) subcmd = do let subcmdOptions = do subcmdName <- subcmd opts <- lookup subcmdName subcmds return (subcmdName, opts) - let (groupInfos, ungroupedMainOptions) = uniqueGroupInfos mainOpts + let (groupInfos, ungroupedMainOptions) = uniqueGroups mainOpts -- Always print --help group - let hasHelp = filter (\(g,_) -> groupInfoName g == "all") groupInfos + let hasHelp = filter (\(g,_) -> groupName g == "all") groupInfos forM_ hasHelp showHelpGroup tell "Application Options:\n" @@ -181,17 +201,17 @@ forM_ subOpts showOptionHelp tell "\n" -showHelpAll :: OptionDefinitions a -> Maybe String -> Writer String () +showHelpAll :: OptionDefinitions -> Maybe String -> Writer String () showHelpAll (OptionDefinitions mainOpts subcmds) subcmd = do let subcmdOptions = do subcmdName <- subcmd opts <- lookup subcmdName subcmds return (subcmdName, opts) - let (groupInfos, ungroupedMainOptions) = uniqueGroupInfos mainOpts + let (groupInfos, ungroupedMainOptions) = uniqueGroups mainOpts -- Always print --help group first, if present - let (hasHelp, noHelp) = partition (\(g,_) -> groupInfoName g == "all") groupInfos + let (hasHelp, noHelp) = partition (\(g,_) -> groupName g == "all") groupInfos forM_ hasHelp showHelpGroup forM_ noHelp showHelpGroup @@ -212,39 +232,31 @@ forM_ subOpts showOptionHelp tell "\n" -showHelpGroup :: (GroupInfo, [OptionInfo]) -> Writer String () +showHelpGroup :: (Group, [OptionInfo]) -> Writer String () showHelpGroup (groupInfo, opts) = do - tell (groupInfoTitle groupInfo ++ ":\n") + tell (groupTitle groupInfo ++ ":\n") forM_ opts showOptionHelp tell "\n" -showHelpOneGroup :: OptionDefinitions a -> String -> Maybe String -> Writer String () -showHelpOneGroup (OptionDefinitions mainOpts subcmds) groupName subcmd = do +showHelpOneGroup :: OptionDefinitions -> String -> Maybe String -> Writer String () +showHelpOneGroup (OptionDefinitions mainOpts subcmds) name subcmd = do let opts = case subcmd of Nothing -> mainOpts Just n -> case lookup n subcmds of Just infos -> mainOpts ++ infos -- both Nothing -> mainOpts - let (groupInfos, _) = uniqueGroupInfos opts + let (groupInfos, _) = uniqueGroups opts -- Always print --help group - let group = filter (\(g,_) -> groupInfoName g == groupName) groupInfos + let group = filter (\(g,_) -> groupName g == name) groupInfos forM_ group showHelpGroup -keyFor :: String -> String -keyFor fieldName = this_pkg ++ ":" ++ this_mod ++ ":" ++ fieldName where - (this_pkg, this_mod) = $(do - loc <- location - let pkg = loc_package loc - let mod' = loc_module loc - [| (pkg, mod') |]) - -uniqueGroupInfos :: [OptionInfo] -> ([(GroupInfo, [OptionInfo])], [OptionInfo]) -uniqueGroupInfos allOptions = (Map.elems infoMap, ungroupedOptions) where +uniqueGroups :: [OptionInfo] -> ([(Group, [OptionInfo])], [OptionInfo]) +uniqueGroups allOptions = (Map.elems infoMap, ungroupedOptions) where infoMap = Map.fromListWith merge $ do opt <- allOptions case optionInfoGroup opt of Nothing -> [] - Just g -> [(groupInfoName g, (g, [opt]))] + Just g -> [(groupName g, (g, [opt]))] merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1) ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)] diff --git a/lib/Options/OptionTypes.hs b/lib/Options/OptionTypes.hs deleted file mode 100644 --- a/lib/Options/OptionTypes.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - --- | --- Module: Options.OptionTypes --- License: MIT -module Options.OptionTypes where - -import Data.Int -import Data.List (intercalate) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import Data.Word - -import qualified Filesystem.Path as Path -import qualified Filesystem.Path.Rules as Path -import Language.Haskell.TH - -data Option a = Option - { - -- | Short flags are a single character. When entered by a user, - -- they are preceded by a dash and possibly other short flags. - -- - -- Short flags must be a letter or a number. - -- - -- Example: An option with @optionShortFlags = [\'p\']@ may be set using: - -- - -- >$ ./app -p 443 - -- >$ ./app -p443 - optionShortFlags :: [Char] - - -- | Long flags are multiple characters. When entered by a user, they - -- are preceded by two dashes. - -- - -- Long flags may contain letters, numbers, @\'-\'@, and @\'_\'@. - -- - -- Example: An option with @optionLongFlags = [\"port\"]@ may be set using: - -- - -- >$ ./app --port 443 - -- >$ ./app --port=443 - , optionLongFlags :: [String] - - -- | Options may have a default value. This will be parsed as if the - -- user had entered it on the command line. - , optionDefault :: String - - -- | There are many types which an application or library might want - -- to use when designing their options. By default, options are - -- strings, but 'optionType' may be set to any supported type. See - -- the \"Option types\" section for a list of supported types. - , optionType :: OptionType a - - -- | An option's description is used with the default implementation - -- of @--help@. It should be a short string describing what the option - -- does. - , optionDescription :: String - - -- | Which group the option is in. See the \"Option groups\" section - -- for details. - , optionGroup :: Group - } - -data Group = Group - { groupName :: Maybe String - - -- | A short title for the group, which is used when printing - -- @--help@ output. - , groupTitle :: String - - -- | A description of the group, which is used when printing - -- @--help@ output. - , groupDescription :: String - } - --- | An option's type determines how the option will be parsed, and which --- Haskell type the parsed value will be stored as. There are many types --- available, covering most basic types and a few more advanced types. -data OptionType a = OptionType Type Bool (String -> Either String a) (Q Exp) - --- | Store an option as a @'Bool'@. The option's value must be either --- @\"true\"@ or @\"false\"@. --- --- Boolean options are unary, which means that their value is optional when --- specified on the command line. If a flag is present, the option is set to --- True. --- --- >$ ./app -q --- >$ ./app --quiet --- --- Boolean options may still be specified explicitly by using long flags with --- the @--flag=value@ format. This is the only way to set a unary flag to --- @\"false\"@. --- --- >$ ./app --quiet=true --- >$ ./app --quiet=false -optionTypeBool :: OptionType Bool -optionTypeBool = OptionType (ConT ''Bool) True parseBool [| parseBool |] - -parseBool :: String -> Either String Bool -parseBool s = case s of - "true" -> Right True - "false" -> Right False - -- TODO: include option flag - _ -> Left (show s ++ " is not in {\"true\", \"false\"}.") - --- | Store an option value as a @'String'@. The value is decoded to Unicode --- first, if needed. The value may contain non-Unicode bytes, in which case --- they will be stored using GHC 7.4's encoding for mixed-use strings. -optionTypeString :: OptionType String -optionTypeString = OptionType (ConT ''String) False Right [| Right |] - --- | Store an option value as a @'Text.Text'@. The value is decoded to Unicode --- first, if needed. If the value cannot be decoded, the stored value may have --- the Unicode substitution character @'\65533'@ in place of some of the --- original input. -optionTypeText :: OptionType Text.Text -optionTypeText = OptionType (ConT ''Text.Text) False parseText [| parseText |] - -parseText :: String -> Either String Text.Text -parseText = Right . Text.pack - --- | Store an option value as a @'Path.FilePath'@. -optionTypeFilePath :: OptionType Path.FilePath -optionTypeFilePath = OptionType (ConT ''Path.FilePath) False parsePath [| parsePath |] - -parsePath :: String -> Either String Path.FilePath -#if defined(CABAL_OS_WINDOWS) -parsePath s = Right (Path.decodeString Path.windows s) -#elif __GLASGOW_HASKELL__ == 702 -parsePath s = Right (Path.decodeString Path.posix_ghc702 s) -#else -parsePath s = Right (Path.decodeString Path.posix_ghc704 s) -#endif - -parseInteger :: String -> Either String Integer -parseInteger s = parsed where - parsed = if valid - then Right (read s) - else Left (show s ++ " is not an integer.") - valid = case s of - [] -> False - '-':s' -> allDigits s' - _ -> allDigits s - allDigits = all (\c -> c >= '0' && c <= '9') - -parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a -parseBoundedIntegral label = parse where - getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer) - getBounds _ min' max' = (toInteger min', toInteger max') - - (minInt, maxInt) = getBounds parse minBound maxBound - - parse s = case parseInteger s of - Left err -> Left err - Right int -> if int < minInt || int > maxInt - then Left (show int ++ " is not within bounds [" ++ show minInt ++ ":" ++ show maxInt ++ "] of type " ++ label ++ ".") - else Right (fromInteger int) - -parseFloat :: Read a => String -> Either String a -parseFloat s = case reads s of - [(x, "")] -> Right x - _ -> Left (show s ++ " is not a number.") - --- | Store an option as an @'Int'@. The option value must be an integer /n/ --- such that @'minBound' <= n <= 'maxBound'@. -optionTypeInt :: OptionType Int -optionTypeInt = OptionType (ConT ''Int) False (parseBoundedIntegral "int") [| parseBoundedIntegral "int" |] - --- | Store an option as an @'Int8'@. The option value must be an integer /n/ --- such that @'minBound' <= n <= 'maxBound'@. -optionTypeInt8 :: OptionType Int8 -optionTypeInt8 = OptionType (ConT ''Int8) False (parseBoundedIntegral "int8") [| parseBoundedIntegral "int8" |] - --- | Store an option as an @'Int16'@. The option value must be an integer /n/ --- such that @'minBound' <= n <= 'maxBound'@. -optionTypeInt16 :: OptionType Int16 -optionTypeInt16 = OptionType (ConT ''Int16) False (parseBoundedIntegral "int16") [| parseBoundedIntegral "int16" |] - --- | Store an option as an @'Int32'@. The option value must be an integer /n/ --- such that @'minBound' <= n <= 'maxBound'@. -optionTypeInt32 :: OptionType Int32 -optionTypeInt32 = OptionType (ConT ''Int32) False (parseBoundedIntegral "int32") [| parseBoundedIntegral "int32" |] - --- | Store an option as an @'Int64'@. The option value must be an integer /n/ --- such that @'minBound' <= n <= 'maxBound'@. -optionTypeInt64 :: OptionType Int64 -optionTypeInt64 = OptionType (ConT ''Int64) False (parseBoundedIntegral "int64") [| parseBoundedIntegral "int64" |] - --- | Store an option as a @'Word'@. The option value must be a positive --- integer /n/ such that @0 <= n <= 'maxBound'@. -optionTypeWord :: OptionType Word -optionTypeWord = OptionType (ConT ''Word) False (parseBoundedIntegral "word") [| parseBoundedIntegral "word" |] - --- | Store an option as a @'Word8'@. The option value must be a positive --- integer /n/ such that @0 <= n <= 'maxBound'@. -optionTypeWord8 :: OptionType Word8 -optionTypeWord8 = OptionType (ConT ''Word8) False (parseBoundedIntegral "word8") [| parseBoundedIntegral "word8" |] - --- | Store an option as a @'Word16'@. The option value must be a positive --- integer /n/ such that @0 <= n <= 'maxBound'@. -optionTypeWord16 :: OptionType Word16 -optionTypeWord16 = OptionType (ConT ''Word16) False (parseBoundedIntegral "word16") [| parseBoundedIntegral "word16" |] - --- | Store an option as a @'Word32'@. The option value must be a positive --- integer /n/ such that @0 <= n <= 'maxBound'@. -optionTypeWord32 :: OptionType Word32 -optionTypeWord32 = OptionType (ConT ''Word32) False (parseBoundedIntegral "word32") [| parseBoundedIntegral "word32" |] - --- | Store an option as a @'Word64'@. The option value must be a positive --- integer /n/ such that @0 <= n <= 'maxBound'@. -optionTypeWord64 :: OptionType Word64 -optionTypeWord64 = OptionType (ConT ''Word64) False (parseBoundedIntegral "word64") [| parseBoundedIntegral "word64" |] - --- | Store an option as an @'Integer'@. The option value must be an integer. --- There is no minimum or maximum value. -optionTypeInteger :: OptionType Integer -optionTypeInteger = OptionType (ConT ''Integer) False parseInteger [| parseInteger |] - --- | Store an option as a @'Float'@. The option value must be a number. Due to --- the imprecision of floating-point math, the stored value might not exactly --- match the user's input. If the user's input is out of range for the --- @'Float'@ type, it will be stored as @Infinity@ or @-Infinity@. -optionTypeFloat :: OptionType Float -optionTypeFloat = OptionType (ConT ''Float) False parseFloat [| parseFloat |] - --- | Store an option as a @'Double'@. The option value must be a number. Due to --- the imprecision of floating-point math, the stored value might not exactly --- match the user's input. If the user's input is out of range for the --- @'Double'@ type, it will be stored as @Infinity@ or @-Infinity@. -optionTypeDouble :: OptionType Double -optionTypeDouble = OptionType (ConT ''Double) False parseFloat [| parseFloat |] - --- | Store an option as a @'Maybe'@ of another type. The value will be --- @Nothing@ if the option was not provided or is an empty string. --- --- @ ---'option' \"optTimeout\" (\\o -> o --- { 'optionLongFlags' = [\"timeout\"] --- , 'optionType' = 'optionTypeMaybe' 'optionTypeInt' --- }) --- @ -optionTypeMaybe :: OptionType a -> OptionType (Maybe a) -optionTypeMaybe (OptionType valType unary valParse valParseExp) = OptionType (AppT (ConT ''Maybe) valType) unary - (parseMaybe valParse) - [| parseMaybe $valParseExp |] - -parseMaybe :: (String -> Either String a) -> String -> Either String (Maybe a) -parseMaybe p s = case s of - "" -> Right (Nothing) - _ -> case p s of - Left err -> Left err - Right a -> Right (Just a) - -$([d| |]) - --- | Store an option as a @'Set.Set'@, using another option type for the --- elements. The separator should be a character that will not occur within --- the values, such as a comma or semicolon. --- --- Duplicate elements in the input are permitted. --- --- @ ---'option' \"optNames\" (\\o -> o --- { 'optionLongFlags' = [\"names\"] --- , 'optionDefault' = \"Alice;Bob;Charles\" --- , 'optionType' = 'optionTypeSet' \';\' 'optionTypeString' --- }) --- @ -optionTypeSet :: Ord a - => Char -- ^ Element separator - -> OptionType a -- ^ Element type - -> OptionType (Set.Set a) -optionTypeSet sep (OptionType valType _ valParse valParseExp) = OptionType (AppT (ConT ''Set.Set) valType) False - (\s -> parseSet valParse (split sep s)) - [| \s -> parseSet $valParseExp (split sep s) |] - --- | Store an option as a 'Map.Map', using other option types for the keys and --- values. --- --- The item separator is used to separate key/value pairs from eachother. It --- should be a character that will not occur within either the keys or values. --- --- The value separator is used to separate the key from the value. It should --- be a character that will not occur within the keys. It may occur within the --- values. --- --- Duplicate keys in the input are permitted. The final value for each key is --- stored. --- --- @ ---'option' \"optNames\" (\\o -> o --- { 'optionLongFlags' = [\"names\"] --- , 'optionDefault' = \"name=Alice;hometown=Bucharest\" --- , 'optionType' = 'optionTypeMap' \';\' \'=\' 'optionTypeString' 'optionTypeString' --- }) --- @ -optionTypeMap :: Ord k - => Char -- ^ Item separator - -> Char -- ^ Key/Value separator - -> OptionType k -- ^ Key type - -> OptionType v -- ^ Value type - -> OptionType (Map.Map k v) -optionTypeMap itemSep keySep (OptionType keyType _ keyParse keyParseExp) (OptionType valType _ valParse valParseExp) = OptionType (AppT (AppT (ConT ''Map.Map) keyType) valType) False - (\s -> parseMap keySep keyParse valParse (split itemSep s)) - [| \s -> parseMap keySep $keyParseExp $valParseExp (split itemSep s) |] - -parseList :: (String -> Either String a) -> [String] -> Either String [a] -parseList p = loop where - loop [] = Right [] - loop (x:xs) = case p x of - Left err -> Left err - Right v -> case loop xs of - Left err -> Left err - Right vs -> Right (v:vs) - -parseSet :: Ord a => (String -> Either String a) -> [String] -> Either String (Set.Set a) -parseSet p strs = case parseList p strs of - Left err -> Left err - Right xs -> Right (Set.fromList xs) - -parseMap :: Ord k => Char -> (String -> Either String k) -> (String -> Either String v) -> [String] -> Either String (Map.Map k v) -parseMap keySep pKey pVal = parsed where - parsed strs = case parseList pItem strs of - Left err -> Left err - Right xs -> Right (Map.fromList xs) - pItem s = case break (== keySep) s of - (sKey, valAndSep) -> case valAndSep of - [] -> Left ("Map item " ++ show s ++ " has no value.") - _ : sVal -> case pKey sKey of - Left err -> Left err - Right key -> case pVal sVal of - Left err -> Left err - Right val -> Right (key, val) - -split :: Char -> String -> [String] -split _ [] = [] -split sep s0 = loop s0 where - loop s = let - (chunk, rest) = break (== sep) s - cont = chunk : loop (tail rest) - in if null rest then [chunk] else cont - -$([d| |]) - --- | Store an option as a list, using another option type for the elements. --- The separator should be a character that will not occur within the values, --- such as a comma or semicolon. --- --- @ ---'option' \"optNames\" (\\o -> o --- { 'optionLongFlags' = [\"names\"] --- , 'optionDefault' = \"Alice;Bob;Charles\" --- , 'optionType' = 'optionTypeList' \';\' 'optionTypeString' --- }) --- @ -optionTypeList :: Char -- ^ Element separator - -> OptionType a -- ^ Element type - -> OptionType [a] -optionTypeList sep (OptionType valType _ valParse valParseExp) = OptionType (AppT ListT valType) False - (\s -> parseList valParse (split sep s)) - [| \s -> parseList $valParseExp (split sep s) |] - --- | Store an option as one of a set of enumerated values. The option --- type must be defined in a separate file. --- --- >-- MyApp/Types.hs --- >data Mode = ModeFoo | ModeBar --- > deriving (Enum) --- --- @ --- -- Main.hs ---import MyApp.Types --- ---'defineOptions' \"MainOptions\" $ do --- 'option' \"optMode\" (\\o -> o --- { 'optionLongFlags' = [\"mode\"] --- , 'optionDefault' = \"foo\" --- , 'optionType' = 'optionTypeEnum' ''Mode --- [ (\"foo\", ModeFoo) --- , (\"bar\", ModeBar) --- ] --- }) --- @ --- --- >$ ./app --- >Running in mode ModeFoo --- >$ ./app --mode=bar --- >Running in mode ModeBar -optionTypeEnum :: Enum a => Name -> [(String, a)] -> OptionType a -optionTypeEnum typeName values = do - let intlist = [(k, fromEnum v) | (k, v) <- values] - let setString = "{" ++ intercalate ", " [show k | (k, _) <- values] ++ "}." - OptionType (ConT typeName) False - (\s -> case lookup s values of - Just v -> Right v - Nothing -> Left (show s ++ " is not in " ++ setString)) - [| \s -> case lookup s intlist of - Just v -> Right (toEnum v) - -- TODO: include option flag and available values - Nothing -> Left (show s ++ " is not in " ++ setString) |] diff --git a/lib/Options/Tokenize.hs b/lib/Options/Tokenize.hs --- a/lib/Options/Tokenize.hs +++ b/lib/Options/Tokenize.hs @@ -4,7 +4,11 @@ -- Module: Options.Tokenize -- License: MIT module Options.Tokenize - ( tokenize + ( Token(..) + , tokenFlagName + , Tokens(..) + , tokensMap + , tokenize ) where import Control.Monad.Error hiding (throwError) @@ -12,16 +16,36 @@ import Control.Monad.State import Data.Functor.Identity import qualified Data.Map +import qualified Data.Set as Set import Options.Types import Options.Util +data Token + = TokenUnary String -- flag name + | Token String String -- flag name, flag value + deriving (Eq, Show) + +tokenFlagName :: Token -> String +tokenFlagName (TokenUnary s) = s +tokenFlagName (Token s _) = s + +data Tokens = Tokens + { tokensList :: [(OptionKey, Token)] + , tokensArgv :: [String] + } + deriving (Show) + +tokensMap :: Tokens -> Data.Map.Map OptionKey Token +tokensMap = Data.Map.fromList . tokensList + data TokState = TokState { stArgv :: [String] , stArgs :: [String] - , stOpts :: [(String, (String, String))] - , stShortKeys :: Data.Map.Map Char (String, Bool) - , stLongKeys :: Data.Map.Map String (String, Bool) + , stOpts :: [(OptionKey, Token)] + , stSeen :: Set.Set OptionKey + , stShortKeys :: Data.Map.Map Char (OptionKey, OptionInfo) + , stLongKeys :: Data.Map.Map String (OptionKey, OptionInfo) , stSubcommands :: [(String, [OptionInfo])] , stSubCmd :: Maybe String } @@ -37,12 +61,13 @@ get = Tok get put = Tok . put -tokenize :: OptionDefinitions a -> [String] -> (Maybe String, Either String (TokensFor a)) +tokenize :: OptionDefinitions -> [String] -> (Maybe String, Either String Tokens) tokenize (OptionDefinitions options subcommands) argv = runIdentity $ do let st = TokState { stArgv = argv , stArgs = [] , stOpts = [] + , stSeen = Set.empty , stShortKeys = toShortKeys options , stLongKeys = toLongKeys options , stSubcommands = subcommands @@ -51,7 +76,7 @@ (err, st') <- runStateT (runErrorT (unTok loop)) st return (stSubCmd st', case err of Left err' -> Left err' - Right _ -> Right (TokensFor (stOpts st') (stArgs st'))) + Right _ -> Right (Tokens (reverse (stOpts st')) (stArgs st'))) loop :: Tok () loop = do @@ -83,13 +108,16 @@ addArg :: String -> Tok () addArg s = modify (\st -> st { stArgs = stArgs st ++ [s] }) -addOpt :: String -> String -> String -> Tok () -addOpt flag key val = do - oldOpts <- gets stOpts - case lookup key oldOpts of - Nothing -> modify (\st -> st { stOpts = stOpts st ++ [(key, (flag, val))] }) +addOpt :: OptionKey -> Token -> Tok () +addOpt key val = do + seen <- gets stSeen + if Set.member key seen -- TODO: include old and new values? - Just _ -> throwError ("Multiple values for flag " ++ flag ++ " were provided.") + then throwError ("Multiple values for flag " ++ tokenFlagName val ++ " were provided.") + else modify (\st -> st + { stOpts = (key, val) : stOpts st + , stSeen = Set.insert key (stSeen st) + }) mergeSubcommand :: String -> [OptionInfo] -> Tok () mergeSubcommand name opts = modify $ \st -> st @@ -105,16 +133,18 @@ (before, after) -> case after of '=' : value -> case Data.Map.lookup before longKeys of Nothing -> throwError ("Unknown flag --" ++ before) - Just (key, _) -> addOpt ("--" ++ before) key value + Just (key, info) -> if optionInfoUnaryOnly info + then throwError ("Flag --" ++ before ++ " takes no parameters.") + else addOpt key (Token ("--" ++ before) value) _ -> case Data.Map.lookup optName longKeys of Nothing -> throwError ("Unknown flag --" ++ optName) - Just (key, unary) -> if unary - then addOpt ("--" ++ optName) key "true" + Just (key, info) -> if optionInfoUnary info + then addOpt key (TokenUnary ("--" ++ optName)) else do next <- nextItem case next of - Nothing -> throwError ("The flag --" ++ optName ++ " requires an argument.") - Just value -> addOpt ("--" ++ optName) key value + Nothing -> throwError ("The flag --" ++ optName ++ " requires a parameter.") + Just value -> addOpt key (Token ("--" ++ optName) value) parseShort :: Char -> String -> Tok () parseShort optChar optValue = do @@ -122,9 +152,11 @@ shortKeys <- gets stShortKeys case Data.Map.lookup optChar shortKeys of Nothing -> throwError ("Unknown flag " ++ optName) - Just (key, unary) -> if unary + Just (key, info) -> if optionInfoUnary info + -- don't check optionInfoUnaryOnly, because that's only set by --help + -- options and they define no short flags. then do - addOpt optName key "true" + addOpt key (TokenUnary optName) case optValue of [] -> return () nextChar:nextValue -> parseShort nextChar nextValue @@ -132,21 +164,21 @@ "" -> do next <- nextItem case next of - Nothing -> throwError ("The flag " ++ optName ++ " requires an argument.") - Just value -> addOpt optName key value - _ -> addOpt optName key optValue + Nothing -> throwError ("The flag " ++ optName ++ " requires a parameter.") + Just value -> addOpt key (Token optName value) + _ -> addOpt key (Token optName optValue) -toShortKeys :: [OptionInfo] -> Data.Map.Map Char (String, Bool) +toShortKeys :: [OptionInfo] -> Data.Map.Map Char (OptionKey, OptionInfo) toShortKeys opts = Data.Map.fromList $ do opt <- opts flag <- optionInfoShortFlags opt - return (flag, (optionInfoKey opt, optionInfoUnary opt)) + return (flag, (optionInfoKey opt, opt)) -toLongKeys :: [OptionInfo] -> Data.Map.Map String (String, Bool) +toLongKeys :: [OptionInfo] -> Data.Map.Map String (OptionKey, OptionInfo) toLongKeys opts = Data.Map.fromList $ do opt <- opts flag <- optionInfoLongFlags opt - return (flag, (optionInfoKey opt, optionInfoUnary opt)) + return (flag, (optionInfoKey opt, opt)) throwError :: String -> Tok a throwError = Tok . Control.Monad.Error.throwError diff --git a/lib/Options/Types.hs b/lib/Options/Types.hs --- a/lib/Options/Types.hs +++ b/lib/Options/Types.hs @@ -3,29 +3,53 @@ -- License: MIT module Options.Types ( OptionDefinitions(..) - , GroupInfo(..) + , Group(..) + , OptionKey(..) + , Location(..) , OptionInfo(..) - , TokensFor(..) ) where -data OptionDefinitions a = OptionDefinitions [OptionInfo] [(String, [OptionInfo])] +data OptionDefinitions = OptionDefinitions [OptionInfo] [(String, [OptionInfo])] -data GroupInfo = GroupInfo - { groupInfoName :: String - , groupInfoTitle :: String - , groupInfoDescription :: String +data Group = Group + { + groupName :: String + + -- | A short title for the group, which is used when printing + -- @--help@ output. + , groupTitle :: String + + -- | A description of the group, which is used when printing + -- @--help@ output. + , groupDescription :: String } deriving (Eq, Show) +data OptionKey + = OptionKey String + | OptionKeyHelpSummary + | OptionKeyHelpGroup String + | OptionKeyGenerated Integer + deriving (Eq, Ord, Show) + +data Location = Location + { locationPackage :: String + , locationModule :: String + , locationFilename :: String + , locationLine :: Integer + } + deriving (Eq, Show) + data OptionInfo = OptionInfo - { optionInfoKey :: String + { optionInfoKey :: OptionKey , optionInfoShortFlags :: [Char] , optionInfoLongFlags :: [String] , optionInfoDefault :: String , optionInfoUnary :: Bool + , optionInfoUnaryOnly :: Bool -- used only for --help and friends , optionInfoDescription :: String - , optionInfoGroup :: Maybe GroupInfo + , optionInfoGroup :: Maybe Group + , optionInfoLocation :: Maybe Location + , optionInfoTypeName :: String } deriving (Eq, Show) - -data TokensFor a = TokensFor [(String, (String, String))] [String] diff --git a/options.cabal b/options.cabal --- a/options.cabal +++ b/options.cabal @@ -1,17 +1,16 @@ name: options -version: 0.1.1 +version: 1.0 license: MIT license-file: license.txt -author: John Millikin -maintainer: John Millikin +author: John Millikin +maintainer: John Millikin build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.8 category: Console -stability: experimental +stability: stable homepage: https://john-millikin.com/software/haskell-options/ -bug-reports: mailto:jmillikin@gmail.com -synopsis: Parsing command-line options +synopsis: A powerful and easy-to-use command-line option parser. description: The @options@ package lets library and application developers easily work with command-line options. @@ -20,16 +19,21 @@ @--message@ and @--quiet@: . @ - {-\# LANGUAGE TemplateHaskell \#-} - . + import Control.Applicative import Options . - defineOptions \"MainOptions\" $ do - stringOption \"optMessage\" \"message\" \"Hello world!\" - \"A message to show the user.\" - boolOption \"optQuiet\" \"quiet\" False - \"Whether to be quiet.\" - + data MainOptions = MainOptions + { optMessage :: String + , optQuiet :: Bool + } + . + instance 'Options' MainOptions where + defineOptions = pure MainOptions + \<*\> simpleOption \"message\" \"Hello world!\" + \"A message to show the user.\" + \<*\> simpleOption \"quiet\" False + \"Whether to be quiet.\" + . main :: IO () main = runCommand $ \\opts args -> do if optQuiet opts @@ -49,67 +53,87 @@ . >$ ./hello --help >Help Options: - > -h, --help Show option summary. - > --help-all Show all help options. + > -h, --help + > Show option summary. + > --help-all + > Show all help options. > >Application Options: - > --message A message to show the user. - > --quiet Whether to be quiet. + > --message :: text + > A message to show the user. + > default: "Hello world!" + > --quiet :: bool + > Whether to be quiet. + > default: false + extra-source-files: cbits/hoehrmann_utf8.c cbits/utf8.c - -- - scripts/common.bash - scripts/run-coverage - scripts/run-tests - -- - tests/options-tests.cabal - tests/OptionsTests.hs - tests/OptionsTests/Defaults.hs - tests/OptionsTests/Help.hs - tests/OptionsTests/OptionTypes.hs - tests/OptionsTests/StringParsing.hs - tests/OptionsTests/Tokenize.hs - tests/OptionsTests/Util.hs source-repository head - type: bazaar - location: https://john-millikin.com/branches/haskell-options/0.1/ + type: git + location: https://john-millikin.com/code/haskell-options/ source-repository this - type: bazaar - location: https://john-millikin.com/branches/haskell-options/0.1/ - tag: haskell-options_0.1.1 + type: git + location: https://john-millikin.com/code/haskell-options/ + tag: haskell-options_1.0 library ghc-options: -Wall -O2 - cc-options: -Wall -O2 + cc-options: -Wall hs-source-dirs: lib - if os(windows) - cpp-options: -DCABAL_OS_WINDOWS - if !os(windows) && impl(ghc < 7.2) cpp-options: -DOPTIONS_ENCODING_UTF8 c-sources: cbits/utf8.c + build-depends: + bytestring >= 0.9 + if impl(ghc > 7.4) + ghc-options: -fwarn-unsafe + build-depends: base >= 4.1 && < 5.0 - , transformers >= 0.2 - , bytestring >= 0.9 , containers >= 0.1 , monads-tf >= 0.1 - , system-filepath >= 0.4 && < 0.5 - , text >= 0.7 - , template-haskell >= 2.3 + , transformers >= 0.2 exposed-modules: Options other-modules: Options.Help - Options.OptionTypes Options.Tokenize Options.Types Options.Util + +test-suite options_tests + type: exitcode-stdio-1.0 + main-is: OptionsTests.hs + + ghc-options: -Wall -O2 + cc-options: -Wall + hs-source-dirs: lib,tests + + if !os(windows) && impl(ghc < 7.2) + cpp-options: -DOPTIONS_ENCODING_UTF8 + c-sources: cbits/utf8.c + build-depends: + bytestring >= 0.9 + + build-depends: + base >= 4.0 && < 5.0 + , chell >= 0.3.1 && < 0.4 + , chell-quickcheck >= 0.2 && < 0.3 + , containers >= 0.1 + , monads-tf >= 0.1 + , transformers >= 0.2 + + other-modules: + OptionsTests.Help + OptionsTests.OptionTypes + OptionsTests.StringParsing + OptionsTests.Tokenize + OptionsTests.Util diff --git a/scripts/common.bash b/scripts/common.bash deleted file mode 100644 --- a/scripts/common.bash +++ /dev/null @@ -1,23 +0,0 @@ -PATH="$PATH:$PWD/cabal-dev/bin/" - -VERSION=$(awk '/^version:/{print $2}' options.cabal) - -CABAL_DEV=$(which cabal-dev) -XZ=$(which xz) - -require_cabal_dev() -{ - if [ -z "$CABAL_DEV" ]; then - echo "Can't find 'cabal-dev' executable; make sure it exists on your "'$PATH' - echo "Cowardly refusing to fuck with the global package database" - exit 1 - fi -} - -clean_dev_install() -{ - require_cabal_dev - - rm -rf dist - $CABAL_DEV install || exit 1 -} diff --git a/scripts/run-coverage b/scripts/run-coverage deleted file mode 100644 --- a/scripts/run-coverage +++ /dev/null @@ -1,31 +0,0 @@ -#!/bin/bash -if [ ! -f 'options.cabal' ]; then - echo -n "Can't find options.cabal; please run this script as" - echo -n " ./scripts/run-coverage from within the haskell-options source" - echo " directory" - exit 1 -fi - -. scripts/common.bash - -require_cabal_dev - -pushd tests -$CABAL_DEV -s ../cabal-dev install --flags="coverage" || exit 1 -popd - -rm -f options_tests.tix -cabal-dev/bin/options_tests $@ - -EXCLUDES="\ ---exclude=OptionsTests \ ---exclude=OptionsTests.Defaults \ ---exclude=OptionsTests.Help \ ---exclude=OptionsTests.OptionTypes \ ---exclude=OptionsTests.StringParsing \ ---exclude=OptionsTests.Tokenize \ ---exclude=OptionsTests.Util \ ---exclude=Main" - -hpc markup --srcdir=lib/ --srcdir=tests/ options_tests.tix --destdir=hpc-markup $EXCLUDES > /dev/null -hpc report --srcdir=lib/ --srcdir=tests/ options_tests.tix $EXCLUDES diff --git a/scripts/run-tests b/scripts/run-tests deleted file mode 100644 --- a/scripts/run-tests +++ /dev/null @@ -1,20 +0,0 @@ -#!/bin/bash -if [ ! -f 'options.cabal' ]; then - echo -n "Can't find options.cabal; please run this script as" - echo -n " ./scripts/run-tests from within the haskell-options source" - echo " directory" - exit 1 -fi - -. scripts/common.bash - -require_cabal_dev - -# clean_dev_install - -pushd tests -# rm -rf dist -$CABAL_DEV -s ../cabal-dev install || exit 1 -popd - -cabal-dev/bin/options_tests $@ diff --git a/tests/OptionsTests.hs b/tests/OptionsTests.hs --- a/tests/OptionsTests.hs +++ b/tests/OptionsTests.hs @@ -8,21 +8,19 @@ import Test.Chell (Suite, defaultMain) -import OptionsTests.Defaults (test_Defaults) -import OptionsTests.Help (test_Help) -import OptionsTests.OptionTypes (test_OptionTypes) -import OptionsTests.StringParsing (test_StringParsing) -import OptionsTests.Tokenize (test_Tokenize) -import OptionsTests.Util (test_Util) +import OptionsTests.Help (suite_Help) +import OptionsTests.OptionTypes (suite_OptionTypes) +import OptionsTests.StringParsing (suite_StringParsing) +import OptionsTests.Tokenize (suite_Tokenize) +import OptionsTests.Util (suite_Util) tests :: [Suite] tests = - [ test_Defaults - , test_Help - , test_OptionTypes - , test_StringParsing - , test_Tokenize - , test_Util + [ suite_Help + , suite_OptionTypes + , suite_StringParsing + , suite_Tokenize + , suite_Util ] main :: IO () diff --git a/tests/OptionsTests/Defaults.hs b/tests/OptionsTests/Defaults.hs deleted file mode 100644 --- a/tests/OptionsTests/Defaults.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- Copyright (C) 2012 John Millikin --- --- See license.txt for details -module OptionsTests.Defaults - ( test_Defaults - ) where - -import Prelude hiding (FilePath) -import Data.Int -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Set as Set -import Data.Set (Set) -import Data.Text (Text) -import Data.Word - -import Filesystem.Path.CurrentOS (FilePath) -import Test.Chell - -import Options - -$(defineOptions "AllOptions" $ do - -- Simple option definitions - boolOption "s_Bool" "s_bool" True "" - stringOption "s_String" "s_string" "abc" "" - stringsOption "s_Strings" "s_strings" ["a", "b", "c"] "" - textOption "s_Text" "s_text" "abc" "" - textsOption "s_Texts" "s_texts" ["a", "b", "c"] "" - pathOption "s_Path" "s_path" "a/b/c" "" - intOption "s_Int" "s_int" 123 "" - integerOption "s_Integer" "s_integer" 123 "" - floatOption "s_Float" "s_float" 123.5 "" - doubleOption "s_Double" "s_double" 123.5 "" - - -- Explicitly typed option definitions - option "t_Bool" (\o -> o - { optionLongFlags = ["t_bool"] - , optionType = optionTypeBool - , optionDefault = "true" - }) - option "t_String" (\o -> o - { optionLongFlags = ["t_String"] - , optionType = optionTypeString - , optionDefault = "abc" - }) - option "t_Text" (\o -> o - { optionLongFlags = ["t_Text"] - , optionType = optionTypeText - , optionDefault = "abc" - }) - option "t_FilePath" (\o -> o - { optionLongFlags = ["t_FilePath"] - , optionType = optionTypeFilePath - , optionDefault = "a/b/c" - }) - option "t_Int" (\o -> o - { optionLongFlags = ["t_Int"] - , optionType = optionTypeInt - , optionDefault = "123" - }) - option "t_Int8" (\o -> o - { optionLongFlags = ["t_Int8"] - , optionType = optionTypeInt8 - , optionDefault = "123" - }) - option "t_Int16" (\o -> o - { optionLongFlags = ["t_Int16"] - , optionType = optionTypeInt16 - , optionDefault = "123" - }) - option "t_Int32" (\o -> o - { optionLongFlags = ["t_Int32"] - , optionType = optionTypeInt32 - , optionDefault = "123" - }) - option "t_Int64" (\o -> o - { optionLongFlags = ["t_Int64"] - , optionType = optionTypeInt64 - , optionDefault = "123" - }) - option "t_Word" (\o -> o - { optionLongFlags = ["t_Word"] - , optionType = optionTypeWord - , optionDefault = "123" - }) - option "t_Word8" (\o -> o - { optionLongFlags = ["t_Word8"] - , optionType = optionTypeWord8 - , optionDefault = "123" - }) - option "t_Word16" (\o -> o - { optionLongFlags = ["t_Word16"] - , optionType = optionTypeWord16 - , optionDefault = "123" - }) - option "t_Word32" (\o -> o - { optionLongFlags = ["t_Word32"] - , optionType = optionTypeWord32 - , optionDefault = "123" - }) - option "t_Word64" (\o -> o - { optionLongFlags = ["t_Word64"] - , optionType = optionTypeWord64 - , optionDefault = "123" - }) - option "t_Integer" (\o -> o - { optionLongFlags = ["t_Integer"] - , optionType = optionTypeInteger - , optionDefault = "123" - }) - option "t_Float" (\o -> o - { optionLongFlags = ["t_Float"] - , optionType = optionTypeFloat - , optionDefault = "123.5" - }) - option "t_Double" (\o -> o - { optionLongFlags = ["t_Double"] - , optionType = optionTypeDouble - , optionDefault = "123.5" - }) - option "t_Maybe" (\o -> o - { optionLongFlags = ["t_Maybe"] - , optionType = optionTypeMaybe optionTypeBool - , optionDefault = "true" - }) - option "t_List" (\o -> o - { optionLongFlags = ["t_List"] - , optionType = optionTypeList ',' optionTypeBool - , optionDefault = "true,false" - }) - option "t_Set" (\o -> o - { optionLongFlags = ["t_Set"] - , optionType = optionTypeSet ',' optionTypeBool - , optionDefault = "true,false" - }) - option "t_Map" (\o -> o - { optionLongFlags = ["t_Map"] - , optionType = optionTypeMap ',' '=' optionTypeString optionTypeBool - , optionDefault = "true=true,false=false" - }) - option "t_Enum" (\o -> o - { optionLongFlags = ["t_Enum"] - , optionType = optionTypeEnum ''Bool - [ ("true", True) - , ("false", False) - ] - , optionDefault = "true" - }) - ) - -test_Defaults :: Suite -test_Defaults = assertions "defaults" $ do - let def = defaultOptions :: AllOptions - - -- Simple option definitions - $expect (equal (s_Bool def) True) - $expect (equal (s_String def) ("abc" :: String)) - $expect (equal (s_Strings def) (["a", "b", "c"] :: [String])) - $expect (equal (s_Text def) ("abc" :: Text)) - $expect (equal (s_Texts def) (["a", "b", "c"] :: [Text])) - $expect (equal (s_Path def) ("a/b/c" :: FilePath)) - $expect (equal (s_Int def) (123 :: Int)) - $expect (equal (s_Integer def) (123 :: Integer)) - $expect (equal (s_Float def) (123.5 :: Float)) - $expect (equal (s_Double def) (123.5 :: Double)) - - -- Explicitly typed option definitions - $expect (equal (t_Bool def) True) - $expect (equal (t_String def) ("abc" :: String)) - $expect (equal (t_Text def) ("abc" :: Text)) - $expect (equal (t_FilePath def) ("a/b/c" :: FilePath)) - $expect (equal (t_Int def) (123 :: Int)) - $expect (equal (t_Int8 def) (123 :: Int8)) - $expect (equal (t_Int16 def) (123 :: Int16)) - $expect (equal (t_Int32 def) (123 :: Int32)) - $expect (equal (t_Int64 def) (123 :: Int64)) - $expect (equal (t_Word def) (123 :: Word)) - $expect (equal (t_Word8 def) (123 :: Word8)) - $expect (equal (t_Word16 def) (123 :: Word16)) - $expect (equal (t_Word32 def) (123 :: Word32)) - $expect (equal (t_Word64 def) (123 :: Word64)) - $expect (equal (t_Integer def) (123 :: Integer)) - $expect (equal (t_Float def) (123.5 :: Float)) - $expect (equal (t_Double def) (123.5 :: Double)) - $expect (equal (t_Maybe def) (Just True :: Maybe Bool)) - $expect (equal (t_List def) ([True,False] :: [Bool])) - $expect (equal (t_Set def) (Set.fromList [True, False] :: Set Bool)) - $expect (equal (t_Map def) (Map.fromList [("true", True), ("false", False)] :: Map String Bool)) - $expect (equal (t_Enum def) True) diff --git a/tests/OptionsTests/Help.hs b/tests/OptionsTests/Help.hs --- a/tests/OptionsTests/Help.hs +++ b/tests/OptionsTests/Help.hs @@ -5,70 +5,75 @@ -- -- See license.txt for details module OptionsTests.Help - ( test_Help + ( suite_Help ) where import Test.Chell -import Options.Types import Options.Help +import Options.Tokenize +import Options.Types -test_Help :: Suite -test_Help = suite "help" - [ test_AddHelpFlags - , test_CheckHelpFlag - , test_ShowHelpSummary - , test_ShowHelpSummary_Subcommand - , test_ShowHelpAll - , test_ShowHelpAll_Subcommand - , test_ShowHelpGroup - , test_ShowHelpGroup_Subcommand - , test_ShowHelpGroup_SubcommandInvalid - ] +suite_Help :: Suite +suite_Help = suite "help" + suite_AddHelpFlags + test_CheckHelpFlag + test_ShowHelpSummary + test_ShowHelpSummary_Subcommand + test_ShowHelpAll + test_ShowHelpAll_Subcommand + test_ShowHelpGroup + test_ShowHelpGroup_Subcommand + test_ShowHelpGroup_SubcommandInvalid -test_AddHelpFlags :: Suite -test_AddHelpFlags = suite "addHelpFlags" - [ test_AddHelpFlags_None - , test_AddHelpFlags_Short - , test_AddHelpFlags_Long - , test_AddHelpFlags_Both - , test_AddHelpFlags_NoAll - , test_AddHelpFlags_Subcommand - ] +suite_AddHelpFlags :: Suite +suite_AddHelpFlags = suite "addHelpFlags" + test_AddHelpFlags_None + test_AddHelpFlags_Short + test_AddHelpFlags_Long + test_AddHelpFlags_Both + test_AddHelpFlags_NoAll + test_AddHelpFlags_Subcommand -groupInfoHelp :: Maybe GroupInfo -groupInfoHelp = Just (GroupInfo - { groupInfoName = "all" - , groupInfoTitle = "Help Options" - , groupInfoDescription = "Show all help options." +groupHelp :: Maybe Group +groupHelp = Just (Group + { groupName = "all" + , groupTitle = "Help Options" + , groupDescription = "Show all help options." }) infoHelpSummary :: [Char] -> [String] -> OptionInfo infoHelpSummary shorts longs = OptionInfo - { optionInfoKey = "main:Options.Help:optHelpSummary" + { optionInfoKey = OptionKeyHelpSummary , optionInfoShortFlags = shorts , optionInfoLongFlags = longs - , optionInfoDefault = "false" + , optionInfoDefault = "" , optionInfoUnary = True + , optionInfoUnaryOnly = True , optionInfoDescription = "Show option summary." - , optionInfoGroup = groupInfoHelp + , optionInfoGroup = groupHelp + , optionInfoLocation = Nothing + , optionInfoTypeName = "" } infoHelpAll :: OptionInfo infoHelpAll = OptionInfo - { optionInfoKey = "main:Options.Help:optHelpGroup:all" + { optionInfoKey = OptionKeyHelpGroup "all" , optionInfoShortFlags = [] , optionInfoLongFlags = ["help-all"] - , optionInfoDefault = "false" + , optionInfoDefault = "" , optionInfoUnary = True + , optionInfoUnaryOnly = True , optionInfoDescription = "Show all help options." - , optionInfoGroup = groupInfoHelp + , optionInfoGroup = groupHelp + , optionInfoLocation = Nothing + , optionInfoTypeName = "" } -test_AddHelpFlags_None :: Suite +test_AddHelpFlags_None :: Test test_AddHelpFlags_None = assertions "none" $ do let commandDefs = OptionDefinitions - [ OptionInfo "test.help" ['h'] ["help"] "default" False "" Nothing + [ OptionInfo (OptionKey "test.help") ['h'] ["help"] "default" False False "" Nothing Nothing "" ] [] let helpAdded = addHelpFlags commandDefs @@ -76,14 +81,14 @@ $expect (equal opts [ infoHelpAll - , OptionInfo "test.help" ['h'] ["help"] "default" False "" Nothing + , OptionInfo (OptionKey "test.help") ['h'] ["help"] "default" False False "" Nothing Nothing "" ]) $expect (equal subcmds []) -test_AddHelpFlags_Short :: Suite +test_AddHelpFlags_Short :: Test test_AddHelpFlags_Short = assertions "short" $ do let commandDefs = OptionDefinitions - [ OptionInfo "test.help" [] ["help"] "default" False "" Nothing + [ OptionInfo (OptionKey "test.help") [] ["help"] "default" False False "" Nothing Nothing "" ] [] let helpAdded = addHelpFlags commandDefs @@ -92,14 +97,14 @@ $expect (equal opts [ infoHelpSummary ['h'] [] , infoHelpAll - , OptionInfo "test.help" [] ["help"] "default" False "" Nothing + , OptionInfo (OptionKey "test.help") [] ["help"] "default" False False "" Nothing Nothing "" ]) $expect (equal subcmds []) -test_AddHelpFlags_Long :: Suite +test_AddHelpFlags_Long :: Test test_AddHelpFlags_Long = assertions "long" $ do let commandDefs = OptionDefinitions - [ OptionInfo "test.help" ['h'] [] "default" False "" Nothing + [ OptionInfo (OptionKey "test.help") ['h'] [] "default" False False "" Nothing Nothing "" ] [] let helpAdded = addHelpFlags commandDefs @@ -108,11 +113,11 @@ $expect (equal opts [ infoHelpSummary [] ["help"] , infoHelpAll - , OptionInfo "test.help" ['h'] [] "default" False "" Nothing + , OptionInfo (OptionKey "test.help") ['h'] [] "default" False False "" Nothing Nothing "" ]) $expect (equal subcmds []) -test_AddHelpFlags_Both :: Suite +test_AddHelpFlags_Both :: Test test_AddHelpFlags_Both = assertions "both" $ do let commandDefs = OptionDefinitions [] [] let helpAdded = addHelpFlags commandDefs @@ -124,32 +129,32 @@ ]) $expect (equal subcmds []) -test_AddHelpFlags_NoAll :: Suite +test_AddHelpFlags_NoAll :: Test test_AddHelpFlags_NoAll = assertions "no-all" $ do let commandDefs = OptionDefinitions - [ OptionInfo "test.help" ['h'] ["help", "help-all"] "default" False "" Nothing + [ OptionInfo (OptionKey "test.help") ['h'] ["help", "help-all"] "default" False False "" Nothing Nothing "" ] [] let helpAdded = addHelpFlags commandDefs let OptionDefinitions opts subcmds = helpAdded $expect (equal opts - [ OptionInfo "test.help" ['h'] ["help", "help-all"] "default" False "" Nothing + [ OptionInfo (OptionKey "test.help") ['h'] ["help", "help-all"] "default" False False "" Nothing Nothing "" ]) $expect (equal subcmds []) -test_AddHelpFlags_Subcommand :: Suite +test_AddHelpFlags_Subcommand :: Test test_AddHelpFlags_Subcommand = assertions "subcommand" $ do - let cmd1_a = OptionInfo "test.cmd1.a" ['a'] [] "" False "" (Just GroupInfo - { groupInfoName = "foo" - , groupInfoTitle = "Foo Options" - , groupInfoDescription = "More Foo Options" - }) - let cmd1_b = OptionInfo "test.cmd1.b" ['b'] [] "" False "" (Just GroupInfo - { groupInfoName = "all" - , groupInfoTitle = "All Options" - , groupInfoDescription = "More All Options" - }) + let cmd1_a = OptionInfo (OptionKey "test.cmd1.a") ['a'] [] "" False False "" (Just Group + { groupName = "foo" + , groupTitle = "Foo Options" + , groupDescription = "More Foo Options" + }) Nothing "" + let cmd1_b = OptionInfo (OptionKey "test.cmd1.b") ['b'] [] "" False False "" (Just Group + { groupName = "all" + , groupTitle = "All Options" + , groupDescription = "More All Options" + }) Nothing "" let commandDefs = OptionDefinitions [] [("cmd1", [cmd1_a, cmd1_b])] @@ -157,17 +162,20 @@ let OptionDefinitions opts subcmds = helpAdded let helpFoo = OptionInfo - { optionInfoKey = "main:Options.Help:optHelpGroup:foo" + { optionInfoKey = OptionKeyHelpGroup "foo" , optionInfoShortFlags = [] , optionInfoLongFlags = ["help-foo"] - , optionInfoDefault = "false" + , optionInfoDefault = "" , optionInfoUnary = True + , optionInfoUnaryOnly = True , optionInfoDescription = "More Foo Options" - , optionInfoGroup = Just (GroupInfo - { groupInfoName = "all" - , groupInfoTitle = "Help Options" - , groupInfoDescription = "Show all help options." + , optionInfoGroup = Just (Group + { groupName = "all" + , groupTitle = "Help Options" + , groupDescription = "Show all help options." }) + , optionInfoLocation = Nothing + , optionInfoTypeName = "" } $expect (equal opts @@ -176,54 +184,64 @@ ]) $expect (equal subcmds [("cmd1", [helpFoo, cmd1_a, cmd1_b])]) -test_CheckHelpFlag :: Suite +test_CheckHelpFlag :: Test test_CheckHelpFlag = assertions "checkHelpFlag" $ do - let checkFlag keys = equal (checkHelpFlag (TokensFor [(k, ("-h", "true")) | k <- keys] [])) + let checkFlag keys = equal (checkHelpFlag (Tokens [(k, TokenUnary "-h") | k <- keys] [])) $expect (checkFlag [] Nothing) - $expect (checkFlag ["main:Options.Help:optHelpSummary"] (Just HelpSummary)) - $expect (checkFlag ["main:Options.Help:optHelpGroup:all"] (Just HelpAll)) - $expect (checkFlag ["main:Options.Help:optHelpGroup:foo"] (Just (HelpGroup "foo"))) + $expect (checkFlag [OptionKeyHelpSummary] (Just HelpSummary)) + $expect (checkFlag [OptionKeyHelpGroup "all"] (Just HelpAll)) + $expect (checkFlag [OptionKeyHelpGroup "foo"] (Just (HelpGroup "foo"))) -variedOptions :: OptionDefinitions () +variedOptions :: OptionDefinitions variedOptions = addHelpFlags $ OptionDefinitions - [ OptionInfo "test.a" ['a'] ["long-a"] "def" False "a description here" Nothing - , OptionInfo "test.long1" [] ["a-looooooooooooong-option"] "def" False "description here" Nothing - , OptionInfo "test.long2" [] ["a-loooooooooooooong-option"] "def" False "description here" Nothing - , OptionInfo "test.b" ['b'] ["long-b"] "def" False "b description here" Nothing - , OptionInfo "test.g" ['g'] ["long-g"] "def" False "g description here" (Just GroupInfo - { groupInfoName = "group" - , groupInfoTitle = "Grouped options" - , groupInfoDescription = "Show grouped options." - }) + [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "def" False False "a description here" Nothing Nothing "" + , OptionInfo (OptionKey "test.long1") [] ["a-looooooooooooong-option"] "def" False False "description here" Nothing Nothing "" + , OptionInfo (OptionKey "test.long2") [] ["a-loooooooooooooong-option"] "def" False False "description here" Nothing Nothing "" + , OptionInfo (OptionKey "test.b") ['b'] ["long-b"] "def" False False "b description here" Nothing Nothing "" + , OptionInfo (OptionKey "test.g") ['g'] ["long-g"] "def" False False "g description here" (Just Group + { groupName = "group" + , groupTitle = "Grouped options" + , groupDescription = "Show grouped options." + }) Nothing "" ] [ ("cmd1", - [ OptionInfo "test.cmd1.z" ['z'] ["long-z"] "def" False "z description here" Nothing + [ OptionInfo (OptionKey "test.cmd1.z") ['z'] ["long-z"] "def" False False "z description here" Nothing Nothing "" ]) , ("cmd2", - [ OptionInfo "test.cmd2.y" ['y'] ["long-y"] "def" False "y description here" Nothing - , OptionInfo "test.cmd2.g2" [] ["long-g2"] "def" False "g2 description here" (Just GroupInfo - { groupInfoName = "group" - , groupInfoTitle = "Grouped options" - , groupInfoDescription = "Show grouped options." - }) + [ OptionInfo (OptionKey "test.cmd2.y") ['y'] ["long-y"] "def" False False "y description here" Nothing Nothing "" + , OptionInfo (OptionKey "test.cmd2.g2") [] ["long-g2"] "def" False False "g2 description here" (Just Group + { groupName = "group" + , groupTitle = "Grouped options" + , groupDescription = "Show grouped options." + }) Nothing "" ]) ] -test_ShowHelpSummary :: Suite +test_ShowHelpSummary :: Test test_ShowHelpSummary = assertions "showHelpSummary" $ do let expected = "\ \Help Options:\n\ - \ -h, --help Show option summary.\n\ - \ --help-all Show all help options.\n\ - \ --help-group Show grouped options.\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ \\n\ \Application Options:\n\ - \ -a, --long-a a description here\n\ - \ --a-looooooooooooong-option description here\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ \ --a-loooooooooooooong-option\n\ \ description here\n\ - \ -b, --long-b b description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ \\n\ \Subcommands:\n\ \ cmd1\n\ @@ -231,97 +249,149 @@ \\n" $expect (equalLines expected (helpFor HelpSummary variedOptions Nothing)) -test_ShowHelpSummary_Subcommand :: Suite +test_ShowHelpSummary_Subcommand :: Test test_ShowHelpSummary_Subcommand = assertions "showHelpSummary-subcommand" $ do let expected = "\ \Help Options:\n\ - \ -h, --help Show option summary.\n\ - \ --help-all Show all help options.\n\ - \ --help-group Show grouped options.\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ \\n\ \Application Options:\n\ - \ -a, --long-a a description here\n\ - \ --a-looooooooooooong-option description here\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ \ --a-loooooooooooooong-option\n\ \ description here\n\ - \ -b, --long-b b description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ \\n\ \Options for subcommand \"cmd1\":\n\ - \ -z, --long-z z description here\n\ + \ -z, --long-z\n\ + \ z description here\n\ + \ default: def\n\ \\n" $expect (equalLines expected (helpFor HelpSummary variedOptions (Just "cmd1"))) -test_ShowHelpAll :: Suite +test_ShowHelpAll :: Test test_ShowHelpAll = assertions "showHelpAll" $ do let expected = "\ \Help Options:\n\ - \ -h, --help Show option summary.\n\ - \ --help-all Show all help options.\n\ - \ --help-group Show grouped options.\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ \\n\ \Grouped options:\n\ - \ -g, --long-g g description here\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ \\n\ \Application Options:\n\ - \ -a, --long-a a description here\n\ - \ --a-looooooooooooong-option description here\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ \ --a-loooooooooooooong-option\n\ \ description here\n\ - \ -b, --long-b b description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ \\n\ \Options for subcommand \"cmd1\":\n\ - \ -z, --long-z z description here\n\ + \ -z, --long-z\n\ + \ z description here\n\ + \ default: def\n\ \\n\ \Options for subcommand \"cmd2\":\n\ - \ -y, --long-y y description here\n\ - \ --long-g2 g2 description here\n\ + \ -y, --long-y\n\ + \ y description here\n\ + \ default: def\n\ + \ --long-g2\n\ + \ g2 description here\n\ + \ default: def\n\ \\n" $expect (equalLines expected (helpFor HelpAll variedOptions Nothing)) -test_ShowHelpAll_Subcommand :: Suite +test_ShowHelpAll_Subcommand :: Test test_ShowHelpAll_Subcommand = assertions "showHelpAll-subcommand" $ do let expected = "\ \Help Options:\n\ - \ -h, --help Show option summary.\n\ - \ --help-all Show all help options.\n\ - \ --help-group Show grouped options.\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ \\n\ \Grouped options:\n\ - \ -g, --long-g g description here\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ \\n\ \Application Options:\n\ - \ -a, --long-a a description here\n\ - \ --a-looooooooooooong-option description here\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ \ --a-loooooooooooooong-option\n\ \ description here\n\ - \ -b, --long-b b description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ \\n\ \Options for subcommand \"cmd1\":\n\ - \ -z, --long-z z description here\n\ + \ -z, --long-z\n\ + \ z description here\n\ + \ default: def\n\ \\n" $expect (equalLines expected (helpFor HelpAll variedOptions (Just "cmd1"))) -test_ShowHelpGroup :: Suite +test_ShowHelpGroup :: Test test_ShowHelpGroup = assertions "showHelpGroup" $ do let expected = "\ \Grouped options:\n\ - \ -g, --long-g g description here\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ \\n" $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions Nothing)) -test_ShowHelpGroup_Subcommand :: Suite +test_ShowHelpGroup_Subcommand :: Test test_ShowHelpGroup_Subcommand = assertions "showHelpGroup-subcommand" $ do let expected = "\ \Grouped options:\n\ - \ -g, --long-g g description here\n\ - \ --long-g2 g2 description here\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ + \ --long-g2\n\ + \ g2 description here\n\ + \ default: def\n\ \\n" $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "cmd2"))) -test_ShowHelpGroup_SubcommandInvalid :: Suite +test_ShowHelpGroup_SubcommandInvalid :: Test test_ShowHelpGroup_SubcommandInvalid = assertions "showHelpGroup-subcommand-invalid" $ do let expected = "\ \Grouped options:\n\ - \ -g, --long-g g description here\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ \\n" $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "noexist"))) diff --git a/tests/OptionsTests/OptionTypes.hs b/tests/OptionsTests/OptionTypes.hs --- a/tests/OptionsTests/OptionTypes.hs +++ b/tests/OptionsTests/OptionTypes.hs @@ -6,66 +6,57 @@ -- -- See license.txt for details module OptionsTests.OptionTypes - ( test_OptionTypes + ( suite_OptionTypes ) where import Data.Int import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.Text as Text import Data.Word -import qualified Filesystem.Path.Rules as Path -import qualified Filesystem.Path.CurrentOS () import Test.Chell -import Options.OptionTypes +import Options -test_OptionTypes :: Suite -test_OptionTypes = suite "option-types" - [ test_Bool - , test_String - , test_Text - , test_FilePath - , test_Int - , test_Int8 - , test_Int16 - , test_Int32 - , test_Int64 - , test_Word - , test_Word8 - , test_Word16 - , test_Word32 - , test_Word64 - , test_Integer - , test_Float - , test_Double - , test_Maybe - , test_List - , test_Set - , test_Map - , test_Enum - ] +suite_OptionTypes :: Suite +suite_OptionTypes = suite "option-types" + test_Bool + test_String + test_Int + test_Int8 + test_Int16 + test_Int32 + test_Int64 + test_Word + test_Word8 + test_Word16 + test_Word32 + test_Word64 + test_Integer + test_Float + test_Double + test_Maybe + test_List + test_Set + test_Map + test_Enum parseValid :: (Show a, Eq a) => OptionType a -> String -> a -> Assertion -parseValid t s expected = equal (optionParser t s) (Right expected) +parseValid t s expected = equal (optionTypeParse t s) (Right expected) parseInvalid :: (Show a, Eq a) => OptionType a -> String -> String -> Assertion -parseInvalid t s err = equal (optionParser t s) (Left err) - -optionParser :: OptionType a -> String -> Either String a -optionParser (OptionType _ _ p _) = p +parseInvalid t s err = equal (optionTypeParse t s) (Left err) -test_Bool :: Suite +test_Bool :: Test test_Bool = assertions "bool" $ do - $expect (parseValid optionTypeBool "true" True) - $expect (parseValid optionTypeBool "false" False) - $expect (parseInvalid optionTypeBool "" "\"\" is not in {\"true\", \"false\"}.") + $expect (parseValid optionType_bool "true" True) + $expect (parseValid optionType_bool "false" False) + $expect (parseInvalid optionType_bool "" "\"\" is not in {\"true\", \"false\"}.") -test_String :: Suite +test_String :: Test test_String = assertions "string" $ do - let valid = parseValid optionTypeString - let invalid = parseInvalid optionTypeString + let valid = parseValid optionType_string + let invalid = parseInvalid optionType_string $expect (valid "" "") $expect (valid "a" "a") @@ -73,40 +64,10 @@ $expect (valid "\56507" "\56507") $expect (valid "\61371" "\61371") -test_Text :: Suite -test_Text = assertions "text" $ do - let p = Text.pack - let valid = parseValid optionTypeText - let invalid = parseInvalid optionTypeText - - $expect (valid "" (p "")) - $expect (valid "a" (p "a")) - $expect (valid "\12354" (p "\12354")) - $expect (valid "\56507" (p "\65533")) - $expect (valid "\61371" (p "\61371")) - -test_FilePath :: Suite -test_FilePath = assertions "filepath" $ do - let p = Path.decodeString Path.posix_ghc704 - let valid = parseValid optionTypeFilePath - let invalid = parseInvalid optionTypeFilePath - - $expect (valid "" (p "")) - $expect (valid "a" (p "a")) - $expect (valid "a-\12403-c.txt" (p "a-\12403-c.txt")) -#if defined(CABAL_OS_WINDOWS) - $expect (valid "a-\61371-c.txt" (p "a-\61371-c.txt")) -#elif __GLASGOW_HASKELL__ == 702 - $expect (valid "a-\61371-c.txt" (p "a-\56507-c.txt")) -#else - $expect (valid "a-\56507-c.txt" (p "a-\56507-c.txt")) - $expect (valid "a-\61371-c.txt" (p "a-\61371-c.txt")) -#endif - -test_Int :: Suite +test_Int :: Test test_Int = assertions "int" $ do - let valid = parseValid optionTypeInt - let invalid = parseInvalid optionTypeInt + let valid = parseValid optionType_int + let invalid = parseInvalid optionType_int $expect (valid "-1" (-1 :: Int)) $expect (valid "1" (1 :: Int)) @@ -121,10 +82,10 @@ $expect (valid (show (maxBound :: Int)) maxBound) $expect (invalid pastMax (pastMax ++ errBounds)) -test_Int8 :: Suite +test_Int8 :: Test test_Int8 = assertions "int8" $ do - let valid = parseValid optionTypeInt8 - let invalid = parseInvalid optionTypeInt8 + let valid = parseValid optionType_int8 + let invalid = parseInvalid optionType_int8 $expect (valid "-1" (-1 :: Int8)) $expect (valid "1" (1 :: Int8)) @@ -137,10 +98,10 @@ $expect (valid (show (maxBound :: Int8)) maxBound) $expect (invalid pastMax "128 is not within bounds [-128:127] of type int8.") -test_Int16 :: Suite +test_Int16 :: Test test_Int16 = assertions "int16" $ do - let valid = parseValid optionTypeInt16 - let invalid = parseInvalid optionTypeInt16 + let valid = parseValid optionType_int16 + let invalid = parseInvalid optionType_int16 $expect (valid "-1" (-1 :: Int16)) $expect (valid "1" (1 :: Int16)) @@ -153,10 +114,10 @@ $expect (valid (show (maxBound :: Int16)) maxBound) $expect (invalid pastMax "32768 is not within bounds [-32768:32767] of type int16.") -test_Int32 :: Suite +test_Int32 :: Test test_Int32 = assertions "int32" $ do - let valid = parseValid optionTypeInt32 - let invalid = parseInvalid optionTypeInt32 + let valid = parseValid optionType_int32 + let invalid = parseInvalid optionType_int32 $expect (valid "-1" (-1 :: Int32)) $expect (valid "1" (1 :: Int32)) @@ -169,10 +130,10 @@ $expect (valid (show (maxBound :: Int32)) maxBound) $expect (invalid pastMax "2147483648 is not within bounds [-2147483648:2147483647] of type int32.") -test_Int64 :: Suite +test_Int64 :: Test test_Int64 = assertions "int64" $ do - let valid = parseValid optionTypeInt64 - let invalid = parseInvalid optionTypeInt64 + let valid = parseValid optionType_int64 + let invalid = parseInvalid optionType_int64 $expect (valid "-1" (-1 :: Int64)) $expect (valid "1" (1 :: Int64)) @@ -185,13 +146,13 @@ $expect (valid (show (maxBound :: Int64)) maxBound) $expect (invalid pastMax "9223372036854775808 is not within bounds [-9223372036854775808:9223372036854775807] of type int64.") -test_Word :: Suite +test_Word :: Test test_Word = assertions "word" $ do - let valid = parseValid optionTypeWord - let invalid = parseInvalid optionTypeWord + let valid = parseValid optionType_word + let invalid = parseInvalid optionType_word let pastMax = show (toInteger (maxBound :: Word) + 1) - let errBounds = " is not within bounds [0:" ++ show (maxBound :: Word) ++ "] of type word." + let errBounds = " is not within bounds [0:" ++ show (maxBound :: Word) ++ "] of type uint." $expect (invalid "-1" ("-1" ++ errBounds)) $expect (valid "0" (0 :: Word)) @@ -201,66 +162,66 @@ $expect (valid (show (maxBound :: Word)) maxBound) $expect (invalid pastMax (pastMax ++ errBounds)) -test_Word8 :: Suite +test_Word8 :: Test test_Word8 = assertions "word8" $ do - let valid = parseValid optionTypeWord8 - let invalid = parseInvalid optionTypeWord8 + let valid = parseValid optionType_word8 + let invalid = parseInvalid optionType_word8 - $expect (invalid "-1" "-1 is not within bounds [0:255] of type word8.") + $expect (invalid "-1" "-1 is not within bounds [0:255] of type uint8.") $expect (valid "0" (0 :: Word8)) $expect (valid "1" (1 :: Word8)) $expect (invalid "a" "\"a\" is not an integer.") let pastMax = show (toInteger (maxBound :: Word8) + 1) $expect (valid (show (maxBound :: Word8)) maxBound) - $expect (invalid pastMax "256 is not within bounds [0:255] of type word8.") + $expect (invalid pastMax "256 is not within bounds [0:255] of type uint8.") -test_Word16 :: Suite +test_Word16 :: Test test_Word16 = assertions "word16" $ do - let valid = parseValid optionTypeWord16 - let invalid = parseInvalid optionTypeWord16 + let valid = parseValid optionType_word16 + let invalid = parseInvalid optionType_word16 - $expect (invalid "-1" "-1 is not within bounds [0:65535] of type word16.") + $expect (invalid "-1" "-1 is not within bounds [0:65535] of type uint16.") $expect (valid "0" (0 :: Word16)) $expect (valid "1" (1 :: Word16)) $expect (invalid "a" "\"a\" is not an integer.") let pastMax = show (toInteger (maxBound :: Word16) + 1) $expect (valid (show (maxBound :: Word16)) maxBound) - $expect (invalid pastMax "65536 is not within bounds [0:65535] of type word16.") + $expect (invalid pastMax "65536 is not within bounds [0:65535] of type uint16.") -test_Word32 :: Suite +test_Word32 :: Test test_Word32 = assertions "word32" $ do - let valid = parseValid optionTypeWord32 - let invalid = parseInvalid optionTypeWord32 + let valid = parseValid optionType_word32 + let invalid = parseInvalid optionType_word32 - $expect (invalid "-1" "-1 is not within bounds [0:4294967295] of type word32.") + $expect (invalid "-1" "-1 is not within bounds [0:4294967295] of type uint32.") $expect (valid "0" (0 :: Word32)) $expect (valid "1" (1 :: Word32)) $expect (invalid "a" "\"a\" is not an integer.") let pastMax = show (toInteger (maxBound :: Word32) + 1) $expect (valid (show (maxBound :: Word32)) maxBound) - $expect (invalid pastMax "4294967296 is not within bounds [0:4294967295] of type word32.") + $expect (invalid pastMax "4294967296 is not within bounds [0:4294967295] of type uint32.") -test_Word64 :: Suite +test_Word64 :: Test test_Word64 = assertions "word64" $ do - let valid = parseValid optionTypeWord64 - let invalid = parseInvalid optionTypeWord64 + let valid = parseValid optionType_word64 + let invalid = parseInvalid optionType_word64 - $expect (invalid "-1" "-1 is not within bounds [0:18446744073709551615] of type word64.") + $expect (invalid "-1" "-1 is not within bounds [0:18446744073709551615] of type uint64.") $expect (valid "0" (0 :: Word64)) $expect (valid "1" (1 :: Word64)) $expect (invalid "a" "\"a\" is not an integer.") let pastMax = show (toInteger (maxBound :: Word64) + 1) $expect (valid (show (maxBound :: Word64)) maxBound) - $expect (invalid pastMax "18446744073709551616 is not within bounds [0:18446744073709551615] of type word64.") + $expect (invalid pastMax "18446744073709551616 is not within bounds [0:18446744073709551615] of type uint64.") -test_Integer :: Suite +test_Integer :: Test test_Integer = assertions "integer" $ do - let valid = parseValid optionTypeInteger - let invalid = parseInvalid optionTypeInteger + let valid = parseValid optionType_integer + let invalid = parseInvalid optionType_integer $expect (invalid "" "\"\" is not an integer.") $expect (valid "-1" (-1 :: Integer)) @@ -268,10 +229,10 @@ $expect (valid "1" (1 :: Integer)) $expect (invalid "a" "\"a\" is not an integer.") -test_Float :: Suite +test_Float :: Test test_Float = assertions "float" $ do - let valid = parseValid optionTypeFloat - let invalid = parseInvalid optionTypeFloat + let valid = parseValid optionType_float + let invalid = parseInvalid optionType_float $expect (valid "-1" (-1 :: Float)) $expect (valid "0" (0 :: Float)) @@ -280,10 +241,10 @@ $expect (valid "3e5" (3e5 :: Float)) $expect (invalid "a" "\"a\" is not a number.") -test_Double :: Suite +test_Double :: Test test_Double = assertions "double" $ do - let valid = parseValid optionTypeDouble - let invalid = parseInvalid optionTypeDouble + let valid = parseValid optionType_double + let invalid = parseInvalid optionType_double $expect (valid "-1" (-1 :: Double)) $expect (valid "0" (0 :: Double)) @@ -292,9 +253,9 @@ $expect (valid "3e5" (3e5 :: Double)) $expect (invalid "a" "\"a\" is not a number.") -test_Maybe :: Suite +test_Maybe :: Test test_Maybe = assertions "maybe" $ do - let t = optionTypeMaybe optionTypeInt + let t = optionType_maybe optionType_int let valid = parseValid t let invalid = parseInvalid t @@ -302,9 +263,9 @@ $expect (valid "1" (Just 1)) $expect (invalid "a" "\"a\" is not an integer.") -test_List :: Suite +test_List :: Test test_List = assertions "list" $ do - let t = optionTypeList ',' optionTypeInt + let t = optionType_list ',' optionType_int let valid = parseValid t let invalid = parseInvalid t @@ -314,9 +275,9 @@ $expect (valid "1,1,2,3" [1, 1, 2, 3]) $expect (invalid "1,a,3" "\"a\" is not an integer.") -test_Set :: Suite +test_Set :: Test test_Set = assertions "set" $ do - let t = optionTypeSet ',' optionTypeInt + let t = optionType_set ',' optionType_int let valid = parseValid t let invalid = parseInvalid t @@ -326,9 +287,9 @@ $expect (valid "1,1,2,3" (Set.fromList [1, 2, 3])) $expect (invalid "1,a,3" "\"a\" is not an integer.") -test_Map :: Suite +test_Map :: Test test_Map = assertions "map" $ do - let t = optionTypeMap ',' '=' optionTypeInt optionTypeInt + let t = optionType_map ',' '=' optionType_int optionType_int let valid = parseValid t let invalid = parseInvalid t @@ -342,18 +303,14 @@ $expect (invalid "1" "Map item \"1\" has no value.") data TestEnum = Enum1 | Enum2 | Enum3 - deriving (Enum, Eq, Show) + deriving (Bounded, Enum, Eq, Show) -test_Enum :: Suite +test_Enum :: Test test_Enum = assertions "enum" $ do - let t = optionTypeEnum ''TestEnum - [ ("e1", Enum1) - , ("e2", Enum2) - , ("e3", Enum3) - ] + let t = optionType_enum "test enum" let valid = parseValid t let invalid = parseInvalid t - $expect (valid "e1" Enum1) - $expect (valid "e2" Enum2) - $expect (invalid "e4" "\"e4\" is not in {\"e1\", \"e2\", \"e3\"}.") + $expect (valid "Enum1" Enum1) + $expect (valid "Enum2" Enum2) + $expect (invalid "Enum4" "\"Enum4\" is not in {\"Enum1\", \"Enum2\", \"Enum3\"}.") diff --git a/tests/OptionsTests/StringParsing.hs b/tests/OptionsTests/StringParsing.hs --- a/tests/OptionsTests/StringParsing.hs +++ b/tests/OptionsTests/StringParsing.hs @@ -1,146 +1,76 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -- Copyright (C) 2012 John Millikin -- -- See license.txt for details module OptionsTests.StringParsing - ( test_StringParsing + ( suite_StringParsing ) where -import Prelude hiding (FilePath) -import Control.Monad (unless) -import Data.Text () - -import qualified Filesystem.Path.Rules as Path -import qualified Filesystem.Path.CurrentOS () +import Control.Applicative import Test.Chell import Options -$(defineOptions "StringOptions" $ do - stringOption "optString" "string" "" "" - textOption "optText" "text" "" "" - pathOption "optPath" "path" (Path.decodeString Path.posix_ghc704 "") "" - - -- String, ASCII default - option "optString_defA" (\o -> o - { optionLongFlags = ["string_defA"] - , optionDefault = "a" - }) - - -- String, Unicode default - option "optString_defU" (\o -> o - { optionLongFlags = ["string_defU"] - , optionDefault = "\12354" - }) - - -- Text, ASCII default - option "optText_defA" (\o -> o - { optionLongFlags = ["text_defA"] - , optionDefault = "a" - , optionType = optionTypeText - }) - - -- Text, Unicode default - option "optText_defU" (\o -> o - { optionLongFlags = ["text_defU"] - , optionDefault = "\12354" - , optionType = optionTypeText - }) - - -- FilePath, ASCII default - option "optPath_defA" (\o -> o - { optionLongFlags = ["path_defA"] - , optionDefault = "a/b/c" - , optionType = optionTypeFilePath - }) - - -- FilePath, Unicode default - option "optPath_defU" (\o -> o - { optionLongFlags = ["path_defU"] - , optionDefault = "\12354/b/c" - , optionType = optionTypeFilePath - }) - - -- FilePath, bytes default - option "optPath_defB" (\o -> o - { optionLongFlags = ["path_defB"] - , optionDefault = "\56507/b/c" - , optionType = optionTypeFilePath - }) - ) +data StringOptions = StringOptions + { optString :: String + , optString_defA :: String + , optString_defU :: String + } -windowsBuild :: Bool -#if defined(CABAL_OS_WINDOWS) -windowsBuild = True -#else -windowsBuild = False -#endif +instance Options StringOptions where + defineOptions = pure StringOptions + <*> simpleOption "string" "" "" + -- String, ASCII default + <*> simpleOption "string_defA" "a" "" + -- String, Unicode default + <*> simpleOption "string_defU" "\12354" "" -test_StringParsing :: Suite -test_StringParsing = suite "string-parsing" - [ test_Defaults - , test_Ascii - , test_UnicodeValid - , skipIf windowsBuild test_UnicodeInvalid - ] +suite_StringParsing :: Suite +suite_StringParsing = suite "string-parsing" + test_Defaults + test_Ascii + test_UnicodeValid + test_UnicodeInvalid -test_Defaults :: Suite +test_Defaults :: Test test_Defaults = assertions "defaults" $ do let opts = defaultOptions $expect (equal (optString_defA opts) "a") $expect (equal (optString_defU opts) "\12354") - - $expect (equal (optText_defA opts) "a") - $expect (equal (optText_defU opts) "\12354") - - $expect (equal (optPath_defA opts) (Path.decodeString Path.posix_ghc704 "a/b/c")) - $expect (equal (optPath_defU opts) (Path.decodeString Path.posix_ghc704 "\12354/b/c")) - unless windowsBuild $ do - $expect (equal (optPath_defB opts) (Path.decodeString Path.posix_ghc704 "\56507/b/c")) -test_Ascii :: Suite +test_Ascii :: Test test_Ascii = assertions "ascii" $ do - let parsed = parseOptions ["--string=a", "--text=a", "--path=a"] + let parsed = parseOptions ["--string=a"] let Just opts = parsedOptions parsed $expect (equal (optString opts) "a") - $expect (equal (optText opts) "a") - $expect (equal (optPath opts) (Path.decodeString Path.posix_ghc704 "a")) -test_UnicodeValid :: Suite +test_UnicodeValid :: Test test_UnicodeValid = assertions "unicode-valid" $ do #if defined(OPTIONS_ENCODING_UTF8) - let parsed = parseOptions ["--string=\227\129\130", "--text=\227\129\130", "--path=\227\129\130/b/c"] + let parsed = parseOptions ["--string=\227\129\130"] #else - let parsed = parseOptions ["--string=\12354", "--text=\12354", "--path=\12354/b/c"] + let parsed = parseOptions ["--string=\12354"] #endif let Just opts = parsedOptions parsed $expect (equal (optString opts) "\12354") - $expect (equal (optText opts) "\12354") - $expect (equal (optPath opts) (Path.decodeString Path.posix_ghc704 "\12354/b/c")) -test_UnicodeInvalid :: Suite +test_UnicodeInvalid :: Test test_UnicodeInvalid = assertions "unicode-invalid" $ do #if __GLASGOW_HASKELL__ >= 704 - let parsed = parseOptions ["--string=\56507", "--text=\56507", "--path=\12354/\56507"] + let parsed = parseOptions ["--string=\56507"] let expectedString = "\56507" - let expectedText = "\65533" #elif __GLASGOW_HASKELL__ >= 702 - let parsed = parseOptions ["--string=\61371", "--text=\61371", "--path=\12354/\61371"] + let parsed = parseOptions ["--string=\61371"] let expectedString = "\61371" - let expectedText = "\61371" #else - let parsed = parseOptions ["--string=\187", "--text=\187", "--path=\227\129\130/\187"] + let parsed = parseOptions ["--string=\187"] let expectedString = "\56507" - let expectedText = "\65533" #endif let Just opts = parsedOptions parsed $expect (equal (optString opts) expectedString) - $expect (equal (optText opts) expectedText) - $expect (equal (optPath opts) (Path.decodeString Path.posix_ghc704 "\12354/\56507")) diff --git a/tests/OptionsTests/Tokenize.hs b/tests/OptionsTests/Tokenize.hs --- a/tests/OptionsTests/Tokenize.hs +++ b/tests/OptionsTests/Tokenize.hs @@ -6,7 +6,7 @@ -- -- See license.txt for details module OptionsTests.Tokenize - ( test_Tokenize + ( suite_Tokenize ) where import Test.Chell @@ -14,99 +14,98 @@ import Options.Types import Options.Tokenize -test_Tokenize :: Suite -test_Tokenize = suite "tokenize" - [ test_Empty - , test_NoFlag - , test_ShortFlag - , test_ShortFlagUnknown - , test_ShortFlagMissing - , test_ShortFlagUnary - , test_ShortFlagDuplicate - , test_LongFlag - , test_LongFlagUnknown - , test_LongFlagMissing - , test_LongFlagUnary - , test_LongFlagDuplicate - , test_EndFlags - , test_Subcommand - , test_SubcommandUnknown - , test_Unicode - ] +suite_Tokenize :: Suite +suite_Tokenize = suite "tokenize" + test_Empty + test_NoFlag + test_ShortFlag + test_ShortFlagUnknown + test_ShortFlagMissing + test_ShortFlagUnary + test_ShortFlagDuplicate + test_LongFlag + test_LongFlagUnknown + test_LongFlagMissing + test_LongFlagUnary + test_LongFlagDuplicate + test_EndFlags + test_Subcommand + test_SubcommandUnknown + test_Unicode -commandDefs :: OptionDefinitions () +commandDefs :: OptionDefinitions commandDefs = OptionDefinitions - [ OptionInfo "test.a" ['a'] ["long-a"] "default" False "" Nothing - , OptionInfo "test.x" ['x'] ["long-x"] "default" True "" Nothing - , OptionInfo "test.y" ['y'] ["long-y"] "default" True "" Nothing - , OptionInfo "test.z" ['z'] ["long-z"] "default" True "" Nothing + [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "default" False False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.x") ['x'] ["long-x"] "default" True False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.y") ['y'] ["long-y"] "default" True False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.z") ['z'] ["long-z"] "default" True False "" Nothing Nothing "" ] [] -subcommandDefs :: OptionDefinitions () +subcommandDefs :: OptionDefinitions subcommandDefs = OptionDefinitions - [ OptionInfo "test.a" ['a'] ["long-a"] "default" False "" Nothing - , OptionInfo "test.b" ['b'] ["long-b"] "default" False "" Nothing - , OptionInfo "test.x" ['x'] ["long-x"] "default" True "" Nothing - , OptionInfo "test.y" ['y'] ["long-y"] "default" True "" Nothing - , OptionInfo "test.z" ['z'] ["long-z"] "default" True "" Nothing + [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "default" False False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.b") ['b'] ["long-b"] "default" False False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.x") ['x'] ["long-x"] "default" True False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.y") ['y'] ["long-y"] "default" True False "" Nothing Nothing "" + , OptionInfo (OptionKey "test.z") ['z'] ["long-z"] "default" True False "" Nothing Nothing "" ] [ ("sub1", - [ OptionInfo "sub.d" ['d'] ["long-d"] "default" False "" Nothing - , OptionInfo "sub.e" ['e'] ["long-e"] "default" True "" Nothing + [ OptionInfo (OptionKey "sub.d") ['d'] ["long-d"] "default" False False "" Nothing Nothing "" + , OptionInfo (OptionKey "sub.e") ['e'] ["long-e"] "default" True False "" Nothing Nothing "" ]) , ("sub2", - [ OptionInfo "sub.d" ['d'] ["long-d"] "default" True "" Nothing - , OptionInfo "sub.e" ['e'] ["long-e"] "default" True "" Nothing + [ OptionInfo (OptionKey "sub.d") ['d'] ["long-d"] "default" True False "" Nothing Nothing "" + , OptionInfo (OptionKey "sub.e") ['e'] ["long-e"] "default" True False "" Nothing Nothing "" ]) ] -unicodeDefs :: OptionDefinitions () +unicodeDefs :: OptionDefinitions unicodeDefs = OptionDefinitions - [ OptionInfo "test.a" ['\12354'] ["long-\12354"] "default" False "" Nothing + [ OptionInfo (OptionKey "test.a") ['\12354'] ["long-\12354"] "default" False False "" Nothing Nothing "" ] [] -test_Empty :: Suite +test_Empty :: Test test_Empty = assertions "empty" $ do let (subcmd, eTokens) = tokenize commandDefs [] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [] tokens) $expect (equal [] args) -test_NoFlag :: Suite +test_NoFlag :: Test test_NoFlag = assertions "no-flag" $ do let (subcmd, eTokens) = tokenize commandDefs ["-", "foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [] tokens) $expect (equal ["-", "foo", "bar"] args) -test_ShortFlag :: Suite +test_ShortFlag :: Test test_ShortFlag = assertions "short-flag" $ do do let (subcmd, eTokens) = tokenize commandDefs ["-a", "foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.a", ("-a", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "-a" "foo")] tokens) $expect (equal ["bar"] args) do let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.a", ("-a", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "-a" "foo")] tokens) $expect (equal ["bar"] args) -test_ShortFlagUnknown :: Suite +test_ShortFlagUnknown :: Test test_ShortFlagUnknown = assertions "short-flag-unknown" $ do let (subcmd, eTokens) = tokenize commandDefs ["-c", "foo", "bar"] $expect (equal Nothing subcmd) @@ -115,35 +114,35 @@ let Left err = eTokens $expect (equal "Unknown flag -c" err) -test_ShortFlagMissing :: Suite +test_ShortFlagMissing :: Test test_ShortFlagMissing = assertions "short-flag-missing" $ do let (subcmd, eTokens) = tokenize commandDefs ["-a"] $expect (equal Nothing subcmd) $assert (left eTokens) let Left err = eTokens - $expect (equal "The flag -a requires an argument." err) + $expect (equal "The flag -a requires a parameter." err) -test_ShortFlagUnary :: Suite +test_ShortFlagUnary :: Test test_ShortFlagUnary = assertions "short-flag-unary" $ do do let (subcmd, eTokens) = tokenize commandDefs ["-x", "foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.x", ("-x", "true"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.x", TokenUnary "-x")] tokens) $expect (equal ["foo", "bar"] args) do let (subcmd, eTokens) = tokenize commandDefs ["-xy", "foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.x", ("-x", "true")), ("test.y", ("-y", "true"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.x", TokenUnary "-x"), ("test.y", TokenUnary "-y")] tokens) $expect (equal ["foo", "bar"] args) -test_ShortFlagDuplicate :: Suite +test_ShortFlagDuplicate :: Test test_ShortFlagDuplicate = assertions "short-flag-duplicate" $ do do let (subcmd, eTokens) = tokenize commandDefs ["-x", "-x"] @@ -167,26 +166,26 @@ let Left err = eTokens $expect (equal "Multiple values for flag -a were provided." err) -test_LongFlag :: Suite +test_LongFlag :: Test test_LongFlag = assertions "long-flag" $ do do let (subcmd, eTokens) = tokenize commandDefs ["--long-a", "foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.a", ("--long-a", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "--long-a" "foo")] tokens) $expect (equal ["bar"] args) do let (subcmd, eTokens) = tokenize commandDefs ["--long-a=foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.a", ("--long-a", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "--long-a" "foo")] tokens) $expect (equal ["bar"] args) -test_LongFlagUnknown :: Suite +test_LongFlagUnknown :: Test test_LongFlagUnknown = assertions "long-flag-unknown" $ do do let (subcmd, eTokens) = tokenize commandDefs ["--long-c", "foo", "bar"] @@ -203,35 +202,35 @@ let Left err = eTokens $expect (equal "Unknown flag --long-c" err) -test_LongFlagMissing :: Suite +test_LongFlagMissing :: Test test_LongFlagMissing = assertions "long-flag-missing" $ do let (subcmd, eTokens) = tokenize commandDefs ["--long-a"] $expect (equal Nothing subcmd) $assert (left eTokens) let Left err = eTokens - $expect (equal "The flag --long-a requires an argument." err) + $expect (equal "The flag --long-a requires a parameter." err) -test_LongFlagUnary :: Suite +test_LongFlagUnary :: Test test_LongFlagUnary = assertions "long-flag-unary" $ do do let (subcmd, eTokens) = tokenize commandDefs ["--long-x", "foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.x", ("--long-x", "true"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.x", TokenUnary "--long-x")] tokens) $expect (equal ["foo", "bar"] args) do let (subcmd, eTokens) = tokenize commandDefs ["--long-x=foo", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.x", ("--long-x", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.x", Token "--long-x" "foo")] tokens) $expect (equal ["bar"] args) -test_LongFlagDuplicate :: Suite +test_LongFlagDuplicate :: Test test_LongFlagDuplicate = assertions "long-flag-duplicate" $ do do let (subcmd, eTokens) = tokenize commandDefs ["-x", "--long-x"] @@ -255,36 +254,36 @@ let Left err = eTokens $expect (equal "Multiple values for flag --long-a were provided." err) -test_EndFlags :: Suite +test_EndFlags :: Test test_EndFlags = assertions "end-flags" $ do let (subcmd, eTokens) = tokenize commandDefs ["foo", "--", "-a", "bar"] $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [] tokens) $expect (equal ["foo", "-a", "bar"] args) -test_Subcommand :: Suite +test_Subcommand :: Test test_Subcommand = assertions "subcommand" $ do do let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub1", "-d", "foo", "--long-e", "bar"] $expect (equal (Just "sub1") subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.x", ("-x", "true")), ("sub.d", ("-d", "foo")), ("sub.e", ("--long-e", "true"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.x", TokenUnary "-x"), ("sub.d", Token "-d" "foo"), ("sub.e", TokenUnary "--long-e")] tokens) $expect (equal ["bar"] args) do let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub2", "-d", "foo", "--long-e", "bar"] $expect (equal (Just "sub2") subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.x", ("-x", "true")), ("sub.d", ("-d", "true")), ("sub.e", ("--long-e", "true"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.x", TokenUnary "-x"), ("sub.d", TokenUnary "-d"), ("sub.e", TokenUnary "--long-e")] tokens) $expect (equal ["foo", "bar"] args) -test_SubcommandUnknown:: Suite +test_SubcommandUnknown:: Test test_SubcommandUnknown = assertions "subcommand-unknown" $ do let (subcmd, eTokens) = tokenize subcommandDefs ["foo"] $expect (equal Nothing subcmd) @@ -293,7 +292,7 @@ let Left err = eTokens $expect (equal "Unknown subcommand \"foo\"." err) -test_Unicode :: Suite +test_Unicode :: Test test_Unicode = assertions "unicode" $ do #if defined(OPTIONS_ENCODING_UTF8) let shortArgs = ["-\227\129\130", "foo", "bar"] @@ -310,14 +309,17 @@ Right _ -> return () $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.a", ("-\12354", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "-\12354" "foo")] tokens) $expect (equal ["bar"] args) do let (subcmd, eTokens) = tokenize unicodeDefs longArgs $expect (equal Nothing subcmd) $assert (right eTokens) - let Right (TokensFor tokens args) = eTokens - $expect (equal [("test.a", ("--long-\12354", "foo"))] tokens) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "--long-\12354" "foo")] tokens) $expect (equal ["bar"] args) + +equalTokens :: [(String, Token)] -> [(OptionKey, Token)] -> Assertion +equalTokens tokens = equal ([(OptionKey k, t) | (k, t) <- tokens]) diff --git a/tests/OptionsTests/Util.hs b/tests/OptionsTests/Util.hs --- a/tests/OptionsTests/Util.hs +++ b/tests/OptionsTests/Util.hs @@ -6,7 +6,7 @@ -- -- See license.txt for details module OptionsTests.Util - ( test_Util + ( suite_Util ) where #if defined(OPTIONS_ENCODING_UTF8) @@ -25,18 +25,17 @@ import Options.Util -test_Util :: Suite -test_Util = suite "util" - [ test_ValidFieldName - , test_ValidShortFlag - , test_ValidLongFlag - , test_HasDuplicates +suite_Util :: Suite +suite_Util = suite "util" + test_ValidFieldName + test_ValidShortFlag + test_ValidLongFlag + test_HasDuplicates #if defined(OPTIONS_ENCODING_UTF8) - , property "decodeUtf8" prop_DecodeUtf8 + property "decodeUtf8" prop_DecodeUtf8 #endif - ] -test_ValidFieldName :: Suite +test_ValidFieldName :: Test test_ValidFieldName = assertions "validFieldName" $ do $expect (validFieldName "a") $expect (validFieldName "abc") @@ -48,7 +47,7 @@ $expect (not (validFieldName "a b")) $expect (not (validFieldName "Ab")) -test_ValidShortFlag :: Suite +test_ValidShortFlag :: Test test_ValidShortFlag = assertions "validShortFlag" $ do $expect (validShortFlag 'a') $expect (validShortFlag 'A') @@ -57,7 +56,7 @@ $expect (not (validShortFlag ' ')) $expect (not (validShortFlag '-')) -test_ValidLongFlag :: Suite +test_ValidLongFlag :: Test test_ValidLongFlag = assertions "validLongFlag" $ do $expect (validLongFlag "a") $expect (validLongFlag "A") @@ -73,7 +72,7 @@ $expect (not (validLongFlag "-")) $expect (not (validLongFlag "--")) -test_HasDuplicates :: Suite +test_HasDuplicates :: Test test_HasDuplicates = assertions "hasDuplicates" $ do $expect (not (hasDuplicates ([] :: [Char]))) $expect (not (hasDuplicates ['a', 'b'])) diff --git a/tests/options-tests.cabal b/tests/options-tests.cabal deleted file mode 100644 --- a/tests/options-tests.cabal +++ /dev/null @@ -1,39 +0,0 @@ -name: options-tests -version: 0 -build-type: Simple -cabal-version: >= 1.6 - -flag coverage - default: False - manual: True - -executable options_tests - main-is: OptionsTests.hs - ghc-options: -Wall - cc-options: -Wall - hs-source-dirs: ../lib,. - - if flag(coverage) - ghc-options: -fhpc - - if os(windows) - cpp-options: -DCABAL_OS_WINDOWS - - if !os(windows) && impl(ghc < 7.2) - cpp-options: -DOPTIONS_ENCODING_UTF8 - c-sources: ../cbits/utf8.c - - build-depends: - base >= 4.0 && < 5.0 - , bytestring - , chell >= 0.2 && < 0.3 - , chell-quickcheck >= 0.1 && < 0.2 - , containers - , monads-tf - , QuickCheck - , split - , system-filepath >= 0.4 && < 0.5 - , template-haskell - , text - , transformers -