packages feed

options 0.1.1 → 1.0

raw patch · 17 files changed

+1619/−2291 lines, 17 filesdep +chelldep +chell-quickcheckdep −system-filepathdep −template-haskelldep −textdep ~base

Dependencies added: chell, chell-quickcheck

Dependencies removed: system-filepath, template-haskell, text

Dependency ranges changed: base

Files

lib/Options.hs view
@@ -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
lib/Options/Help.hs view
@@ -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)]
− lib/Options/OptionTypes.hs 
@@ -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) |]
lib/Options/Tokenize.hs view
@@ -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
lib/Options/Types.hs view
@@ -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]
options.cabal view
@@ -1,17 +1,16 @@ name: options-version: 0.1.1+version: 1.0 license: MIT license-file: license.txt-author: John Millikin <jmillikin@gmail.com>-maintainer: John Millikin <jmillikin@gmail.com>+author: John Millikin <john@john-millikin.com>+maintainer: John Millikin <john@john-millikin.com> 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@:   .   @-  &#x7b;-\# LANGUAGE TemplateHaskell \#-&#x7d;-  .+  import Control.Applicative   import Options   .-  defineOptions \"MainOptions\" $ do-  &#x20;   stringOption \"optMessage\" \"message\" \"Hello world!\"-  &#x20;       \"A message to show the user.\"-  &#x20;   boolOption \"optQuiet\" \"quiet\" False-  &#x20;       \"Whether to be quiet.\"-  &#x20;+  data MainOptions = MainOptions+  &#x20;   &#x7b; optMessage :: String+  &#x20;   , optQuiet :: Bool+  &#x20;   &#x7d;+  .+  instance 'Options' MainOptions where+  &#x20;   defineOptions = pure MainOptions+  &#x20;       \<*\> simpleOption \"message\" \"Hello world!\"+  &#x20;           \"A message to show the user.\"+  &#x20;       \<*\> simpleOption \"quiet\" False+  &#x20;           \"Whether to be quiet.\"+  .   main :: IO ()   main = runCommand $ \\opts args -> do   &#x20;   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
− scripts/common.bash 
@@ -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-}
− scripts/run-coverage 
@@ -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
− scripts/run-tests 
@@ -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 $@
tests/OptionsTests.hs view
@@ -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 ()
− tests/OptionsTests/Defaults.hs 
@@ -1,192 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}---- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>------ 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)
tests/OptionsTests/Help.hs view
@@ -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")))
tests/OptionsTests/OptionTypes.hs view
@@ -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\"}.")
tests/OptionsTests/StringParsing.hs view
@@ -1,146 +1,76 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}  -- Copyright (C) 2012 John Millikin <jmillikin@gmail.com> -- -- 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"))
tests/OptionsTests/Tokenize.hs view
@@ -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])
tests/OptionsTests/Util.hs view
@@ -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']))
− tests/options-tests.cabal 
@@ -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-