packages feed

options (empty) → 0.1

raw patch · 22 files changed

+3791/−0 lines, 22 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, monads-tf, system-filepath, template-haskell, text, transformers

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/hoehrmann_utf8.c view
@@ -0,0 +1,60 @@+/**+ * Copyright (c) 2008-2010 Björn Höhrmann <bjoern@hoehrmann.de>+ *+ * Permission is hereby granted, free of charge, to any person obtaining+ * a copy of this software and associated documentation files (the+ * "Software"), to deal in the Software without restriction, including+ * without limitation the rights to use, copy, modify, merge, publish,+ * distribute, sublicense, and/or sell copies of the Software, and to+ * permit persons to whom the Software is furnished to do so, subject to+ * the following conditions:+ *+ * The above copyright notice and this permission notice shall be included+ * in all copies or substantial portions of the Software.+ *+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+ * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+ * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+ * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+ * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+**/++#define UTF8_ACCEPT 0+#define UTF8_REJECT 12++static const uint8_t utf8d[] = {+  /* The first part of the table maps bytes to character classes that+   * to reduce the size of the transition table and create bitmasks.+   */+   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+   1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,  9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,+   7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,  7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,+   8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,  2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,+  10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,++  /* The second part is a transition table that maps a combination+   * of a state of the automaton and a character class to a state.+   */+   0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,+  12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,+  12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,+  12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,+  12,36,12,12,12,12,12,12,12,12,12,12,+};++static inline uint32_t+decode(uint32_t* state, uint32_t* codep, uint32_t byte) {+  uint32_t type = utf8d[byte];++  *codep = (*state != UTF8_ACCEPT) ?+    (byte & 0x3fu) | (*codep << 6) :+    (0xff >> type) & (byte);++  *state = utf8d[256 + *state + type];+  return *state;+}
+ cbits/utf8.c view
@@ -0,0 +1,102 @@+#include <stdint.h>+#include "hoehrmann_utf8.c"++#include <stdio.h>++/* Decode a UTF8-encoded string to UCS4 using the Höhrmann decoder. Any+ * invalid bytes are stored using GHC 7.4's encoding for mixed-use strings.+ *+ * 'len' is the length of both 'utf8' and 'out'.+ *+ * Returns the number of items written to *out.+ */+int hsoptions_decode_string(uint8_t *utf8, uint32_t *out, int len)+{+	uint32_t state = UTF8_ACCEPT;+	uint8_t *utf8_end = utf8 + len;+	uint32_t codepoint = 0;+	uint32_t *out_orig = out;+	uint8_t *started_accept = utf8;+	+	while (utf8 < utf8_end)+	{+#if defined(__i386__) || defined(__x86_64__)+		/* Performance improvement from Bryan O'Sullivan.+		 *+		 * If some chunk of bytes is ASCII, it can be quickly pushed+		 * off into the output buffer without going through the UTF8+		 * decoder. On little-endian systems, pure-ASCII text will+		 * have a mask of 0x80808080.+		 */+		if (state == UTF8_ACCEPT)+		{+			while (utf8 < utf8_end - 4)+			{+				codepoint = *((uint32_t *) utf8);+				if ((codepoint & 0x80808080) != 0)+				{ break; }+				+				utf8 += 4;+				*out++ = codepoint & 0xFF;+				*out++ = (codepoint >> 8) & 0xFF;+				*out++ = (codepoint >> 16) & 0xFF;+				*out++ = (codepoint >> 24) & 0xFF;+			}+			started_accept = utf8;+		}+#endif+		switch (decode(&state, &codepoint, *utf8))+		{+		case UTF8_ACCEPT:+			/* Read a codepoint succesfully. Copy it out and+			 * continue.+			 */+			*out++ = codepoint;+			started_accept = utf8++;+			break;+		case UTF8_REJECT:+			/* The first byte of a new character was invalid.+			 * Escape it and begin again.+			 */+			if (started_accept == utf8)+			{+				*out++ = (uint32_t) (*utf8++) + 0xDC00;+				started_accept = utf8;+			}+			+			/* The decoder consumed some bytes before failing.+			 * Backtrack to escape everything after the last+			 * successfully read codepoint.+			 */+			else while (started_accept < utf8)+			{+				*out++ = (uint32_t) (*started_accept++) + 0xDC00;+			}+			+			/* Continue looking for valid UTF8 sequences in the+			 * input buffer.+			 */+			state = UTF8_ACCEPT;+			break;+		default:+			/* Decoder needs more input */+			utf8++;+			break;+		}+	}+	+	/* See comments in case UTF8_REJECT. */+	if (state != UTF8_ACCEPT)+	{+		if (started_accept == utf8)+		{+			*out++ = (uint32_t) (*utf8) + 0xDC00;+		}+		else while (started_accept < utf8)+		{+			*out++ = (uint32_t) (*started_accept++) + 0xDC00;+		}+	}+	+	return out - out_orig;+}
+ lib/Options.hs view
@@ -0,0 +1,969 @@+{-# 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+runSubcommand :: (Options opts, MonadIO m) => [Subcommand opts (m a)] -> m a+runSubcommand subcommands = do+	argv <- liftIO System.Environment.getArgs+	let parsed = parseSubcommand subcommands argv+	case parsedSubcommand parsed of+		Just cmd -> cmd+		Nothing -> liftIO $ case parsedError parsed of+			Just err -> do+				hPutStrLn stderr (parsedHelp parsed)+				hPutStrLn stderr err+				exitFailure+			Nothing -> do+				hPutStr stdout (parsedHelp parsed)+				exitSuccess
+ lib/Options/Help.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module: Options.Help+-- License: MIT+module Options.Help+	( addHelpFlags+	, checkHelpFlag+	, helpFor+	, HelpFlag(..)+	) where++import           Control.Monad.Writer+import           Data.List (intercalate, partition, stripPrefix)+import           Data.Maybe (isNothing, listToMaybe, maybeToList)+import qualified Data.Set as Set+import qualified Data.Map as Map++import           Language.Haskell.TH (location, loc_package, loc_module)++import           Options.Types++data HelpFlag = HelpSummary | HelpAll | HelpGroup String+	deriving (Eq, Show)++addHelpFlags :: OptionDefinitions a -> OptionDefinitions a+addHelpFlags (OptionDefinitions opts subcmds) = OptionDefinitions withHelp subcmdsWithHelp where+	shortFlags = Set.fromList $ do+		opt <- opts+		optionInfoShortFlags opt+	longFlags = Set.fromList $ do+		opt <- opts+		optionInfoLongFlags opt+	+	withHelp = optHelpSummary ++ optsGroupHelp ++ opts+	+	groupHelp = GroupInfo+		{ groupInfoName = "all"+		, groupInfoTitle = "Help Options"+		, groupInfoDescription = "Show all help options."+		}+	+	optSummary = OptionInfo+		{ optionInfoKey = keyFor "optHelpSummary"+		, optionInfoShortFlags = []+		, optionInfoLongFlags = []+		, optionInfoDefault = "false"+		, optionInfoUnary = True+		, optionInfoDescription = "Show option summary."+		, optionInfoGroup = Just groupHelp+		}+	+	optGroupHelp group flag = OptionInfo+		{ optionInfoKey = keyFor "optHelpGroup" ++ ":" ++ groupInfoName group+		, optionInfoShortFlags = []+		, optionInfoLongFlags = [flag]+		, optionInfoDefault = "false"+		, optionInfoUnary = True+		, optionInfoDescription = groupInfoDescription group+		, optionInfoGroup = Just groupHelp+		}+	+	optHelpSummary = if Set.member 'h' shortFlags+		then if Set.member "help" longFlags+			then []+			else [optSummary+				{ optionInfoLongFlags = ["help"]+				}]+		else if Set.member "help" longFlags+			then [optSummary+				{ optionInfoShortFlags = ['h']+				}]+			else [optSummary+				{ optionInfoShortFlags = ['h']+				, optionInfoLongFlags = ["help"]+				}]+	+	optsGroupHelp = do+		let (groupsAndOpts, _) = uniqueGroupInfos opts+		let groups = [g | (g, _) <- groupsAndOpts]+		group <- (groupHelp : groups)+		let flag = "help-" ++ groupInfoName group+		if Set.member flag longFlags+			then []+			else [optGroupHelp group flag]+	+	subcmdsWithHelp = do+		(subcmdName, subcmdOpts) <- subcmds+		let subcmdLongFlags = Set.fromList $ do+			opt <- subcmdOpts ++ optsGroupHelp+			optionInfoLongFlags opt+		+		let (groupsAndOpts, _) = uniqueGroupInfos subcmdOpts+		let groups = [g | (g, _) <- groupsAndOpts]+		let newOpts = do+			group <- groups+			let flag = "help-" ++ groupInfoName 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+	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:"++helpFor :: HelpFlag -> OptionDefinitions a -> 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)++showOptionHelp :: OptionInfo -> Writer String ()+showOptionHelp info = do+	let safeHead xs = case xs of+		[] -> []+		(x:_) -> [x]+	let shorts = optionInfoShortFlags info+	let longs = optionInfoLongFlags info+	let optStrings = map (\x -> ['-', x]) (safeHead shorts) ++ map (\x -> "--" ++ x) (safeHead longs)+	unless (null optStrings) $ do+		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)+		+		tell "\n"++showHelpSummary :: OptionDefinitions a -> 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+	+	-- Always print --help group+	let hasHelp = filter (\(g,_) -> groupInfoName g == "all") groupInfos+	forM_ hasHelp showHelpGroup+	+	tell "Application Options:\n"+	forM_ ungroupedMainOptions showOptionHelp+	unless (null subcmds) (tell "\n")+	+	case subcmdOptions of+		Nothing -> unless (null subcmds) $ do+			tell "Subcommands:\n"+			forM_ subcmds $ \(subcmdName, _) -> do+				tell "  "+				tell subcmdName+				-- TODO: subcommand help description+				tell "\n"+			tell "\n"+		Just (n, subOpts) -> do+			-- TODO: subcommand description+			-- TODO: handle grouped options in subcommands?+			tell ("Options for subcommand " ++ show n ++ ":\n")+			forM_ subOpts showOptionHelp+			tell "\n"++showHelpAll :: OptionDefinitions a -> 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+	+	-- Always print --help group first, if present+	let (hasHelp, noHelp) = partition (\(g,_) -> groupInfoName g == "all") groupInfos+	forM_ hasHelp showHelpGroup+	forM_ noHelp showHelpGroup+	+	tell "Application Options:\n"+	forM_ ungroupedMainOptions showOptionHelp+	unless (null subcmds) (tell "\n")+	+	case subcmdOptions of+		Nothing -> forM_ subcmds $ \(subcmdName, subcmdOpts) -> do+			-- no subcommand description+			tell ("Options for subcommand " ++ show subcmdName ++ ":\n")+			forM_ subcmdOpts showOptionHelp+			tell "\n"+		Just (n, subOpts) -> do+			-- TODO: subcommand description+			-- TODO: handle grouped options in subcommands?+			tell ("Options for subcommand " ++ show n ++ ":\n")+			forM_ subOpts showOptionHelp+			tell "\n"++showHelpGroup :: (GroupInfo, [OptionInfo]) -> Writer String ()+showHelpGroup (groupInfo, opts) = do+	tell (groupInfoTitle groupInfo ++ ":\n")+	forM_ opts showOptionHelp+	tell "\n"++showHelpOneGroup :: OptionDefinitions a -> String -> Maybe String -> Writer String ()+showHelpOneGroup (OptionDefinitions mainOpts subcmds) groupName 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+	+	-- Always print --help group+	let group = filter (\(g,_) -> groupInfoName g == groupName) 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+	infoMap = Map.fromListWith merge $ do+		opt <- allOptions+		case optionInfoGroup opt of+			Nothing -> []+			Just g -> [(groupInfoName g, (g, [opt]))]+	merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1)+	ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)]
+ lib/Options/OptionTypes.hs view
@@ -0,0 +1,401 @@+{-# 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
@@ -0,0 +1,152 @@+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module: Options.Tokenize+-- License: MIT+module Options.Tokenize+	( tokenize+	) where++import           Control.Monad.Error hiding (throwError)+import qualified Control.Monad.Error+import           Control.Monad.State+import           Data.Functor.Identity+import qualified Data.Map++import           Options.Types+import           Options.Util++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)+	, stSubcommands :: [(String, [OptionInfo])]+	, stSubCmd :: Maybe String+	}++newtype Tok a = Tok { unTok :: ErrorT String (StateT TokState Identity) a }++instance Monad Tok where+	return = Tok . return+	m >>= f = Tok (unTok m >>= unTok . f)++instance MonadState Tok where+	type StateType Tok = TokState+	get = Tok get+	put = Tok . put++tokenize :: OptionDefinitions a -> [String] -> (Maybe String, Either String (TokensFor a))+tokenize (OptionDefinitions options subcommands) argv = runIdentity $ do+	let st = TokState+		{ stArgv = argv+		, stArgs = []+		, stOpts = []+		, stShortKeys = toShortKeys options+		, stLongKeys = toLongKeys options+		, stSubcommands = subcommands+		, stSubCmd = Nothing+		}+	(err, st') <- runStateT (runErrorT (unTok loop)) st+	return (stSubCmd st', case err of+		Left err' -> Left err'+		Right _ -> Right (TokensFor (stOpts st') (stArgs st')))++loop :: Tok ()+loop = do+	ms <- nextItem+	st <- get+	case ms of+		Nothing -> return ()+		Just s -> (>> loop) $ case stringToGhc704 s of+			'-':'-':[] -> put (st { stArgv = [], stArgs = stArgs st ++ stArgv st })+			'-':'-':opt -> parseLong opt+			'-':optChar:optValue -> parseShort optChar optValue+			'-':[] -> addArg s+			decoded -> case (stSubcommands st, stSubCmd st) of+				([], _) -> addArg s+				(_, Just _) -> addArg s+				(_, Nothing) -> case lookup decoded (stSubcommands st) of+					Nothing -> throwError ("Unknown subcommand " ++ show decoded ++ ".")+					Just subOptions -> mergeSubcommand decoded subOptions++nextItem :: Tok (Maybe String)+nextItem = do+	st <- get+	case stArgv st of+		[] -> return Nothing+		(x:xs) -> do+			put (st { stArgv = xs })+			return (Just x)++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))] })+		-- TODO: include old and new values?+		Just _ -> throwError ("Multiple values for flag " ++ flag ++ " were provided.")++mergeSubcommand :: String -> [OptionInfo] -> Tok ()+mergeSubcommand name opts = modify $ \st -> st+	{ stSubCmd = Just name+	, stShortKeys = Data.Map.union (stShortKeys st) (toShortKeys opts)+	, stLongKeys = Data.Map.union (stLongKeys st) (toLongKeys opts)+	}++parseLong :: String -> Tok ()+parseLong optName = do+	longKeys <- gets stLongKeys+	case break (== '=') optName of+		(before, after) -> case after of+			'=' : value -> case Data.Map.lookup before longKeys of+				Nothing -> throwError ("Unknown flag --" ++ before)+				Just (key, _) -> addOpt ("--" ++ before) key value+			_ -> case Data.Map.lookup optName longKeys of+				Nothing -> throwError ("Unknown flag --" ++ optName)+				Just (key, unary) -> if unary+					then addOpt ("--" ++ optName) key "true"+					else do+						next <- nextItem+						case next of+							Nothing -> throwError ("The flag --" ++ optName ++ " requires an argument.")+							Just value -> addOpt ("--" ++ optName) key value++parseShort :: Char -> String -> Tok ()+parseShort optChar optValue = do+	let optName = '-' : [optChar]+	shortKeys <- gets stShortKeys+	case Data.Map.lookup optChar shortKeys of+		Nothing -> throwError ("Unknown flag " ++ optName)+		Just (key, unary) -> if unary+			then do+				addOpt optName key "true"+				case optValue of+					[] -> return ()+					nextChar:nextValue -> parseShort nextChar nextValue+			else case optValue of+				"" -> do+					next <- nextItem+					case next of+						Nothing -> throwError ("The flag " ++ optName ++ " requires an argument.")+						Just value -> addOpt optName key value+				_ -> addOpt optName key optValue++toShortKeys :: [OptionInfo] -> Data.Map.Map Char (String, Bool)+toShortKeys opts = Data.Map.fromList $ do+	opt <- opts+	flag <- optionInfoShortFlags opt+	return (flag, (optionInfoKey opt, optionInfoUnary opt))++toLongKeys :: [OptionInfo] -> Data.Map.Map String (String, Bool)+toLongKeys opts = Data.Map.fromList $ do+	opt <- opts+	flag <- optionInfoLongFlags opt+	return (flag, (optionInfoKey opt, optionInfoUnary opt))++throwError :: String -> Tok a+throwError = Tok . Control.Monad.Error.throwError
+ lib/Options/Types.hs view
@@ -0,0 +1,31 @@+-- |+-- Module: Options.Types+-- License: MIT+module Options.Types+	( OptionDefinitions(..)+	, GroupInfo(..)+	, OptionInfo(..)+	, TokensFor(..)+	) where++data OptionDefinitions a = OptionDefinitions [OptionInfo] [(String, [OptionInfo])]++data GroupInfo = GroupInfo+	{ groupInfoName :: String+	, groupInfoTitle :: String+	, groupInfoDescription :: String+	}+	deriving (Eq, Show)++data OptionInfo = OptionInfo+	{ optionInfoKey :: String+	, optionInfoShortFlags :: [Char]+	, optionInfoLongFlags :: [String]+	, optionInfoDefault :: String+	, optionInfoUnary :: Bool+	, optionInfoDescription :: String+	, optionInfoGroup :: Maybe GroupInfo+	}+	deriving (Eq, Show)++data TokensFor a = TokensFor [(String, (String, String))] [String]
+ lib/Options/Util.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}++-- |+-- Module: Options.Util+-- License: MIT+module Options.Util where++import           Data.Char (isAlphaNum, isLetter, isUpper)+import qualified Data.Set as Set++#if defined(OPTIONS_ENCODING_UTF8)+import           Data.Char (chr)+import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.ByteString.Char8 as Char8+import           Foreign+import           Foreign.C+#endif++stringToGhc704 :: String -> String+#if defined(OPTIONS_ENCODING_UTF8)+stringToGhc704 = decodeUtf8 . Char8.pack++decodeUtf8 :: Char8.ByteString -> String+decodeUtf8 bytes = map (chr . fromIntegral) word32s where+	word32s = unsafePerformIO (unsafeUseAsCStringLen bytes io)+	io (bytesPtr, len) = allocaArray len $ \wordsPtr -> do+		nWords <- c_decodeString (castPtr bytesPtr) wordsPtr (fromIntegral len)+		peekArray (fromIntegral nWords) wordsPtr++foreign import ccall unsafe "hsoptions_decode_string"+	c_decodeString :: Ptr Word8 -> Ptr Word32 -> CInt -> IO CInt+#else+stringToGhc704 = id+#endif++validFieldName :: String -> Bool+validFieldName = valid where+	valid s = case s of+		[] -> False+		c : cs -> validFirst c && all validGeneral cs+	validFirst c = c == '_' || (isLetter c && not (isUpper c))+	validGeneral c = isAlphaNum c || c == '_' || c == '\''++validShortFlag :: Char -> Bool+validShortFlag = isAlphaNum++validLongFlag :: String -> Bool+validLongFlag = valid where+	valid s = case s of+		[] -> False+		c : cs -> validFirst c && all validGeneral cs+	validFirst = isAlphaNum+	validGeneral c = isAlphaNum c || c == '-' || c == '_'++hasDuplicates :: Ord a => [a] -> Bool+hasDuplicates xs = Set.size (Set.fromList xs) /= length xs
+ license.txt view
@@ -0,0 +1,22 @@+Copyright (c) 2012 John Millikin++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ options.cabal view
@@ -0,0 +1,115 @@+name: options+version: 0.1+license: MIT+license-file: license.txt+author: John Millikin <jmillikin@gmail.com>+maintainer: John Millikin <jmillikin@gmail.com>+build-type: Simple+cabal-version: >= 1.6+category: Console+stability: experimental+homepage: https://john-millikin.com/software/haskell-options/+bug-reports: mailto:jmillikin@gmail.com++synopsis: Parsing command-line options+description:+  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@:+  .+  @+  &#x7b;-\# LANGUAGE TemplateHaskell \#-&#x7d;+  .+  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;+  main :: IO ()+  main = runCommand $ \\opts args -> do+  &#x20;   if optQuiet opts+  &#x20;       then return ()+  &#x20;       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.++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/++source-repository this+  type: bazaar+  location: https://john-millikin.com/branches/haskell-options/0.1/+  tag: haskell-options_0.1++library+  ghc-options: -Wall -O2+  cc-options: -Wall -O2+  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:+      base >= 4.0 && < 5.0+    , transformers >= 0.2 && < 0.3+    , bytestring >= 0.9 && < 0.10+    , containers >= 0.1 && < 0.5+    , monads-tf+    , system-filepath >= 0.4 && < 0.5+    , text >= 0.7 && < 0.12+    , template-haskell++  exposed-modules:+    Options++  other-modules:+    Options.Help+    Options.OptionTypes+    Options.Tokenize+    Options.Types+    Options.Util
+ scripts/common.bash view
@@ -0,0 +1,23 @@+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 view
@@ -0,0 +1,31 @@+#!/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 view
@@ -0,0 +1,20 @@+#!/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
@@ -0,0 +1,29 @@+-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- See license.txt for details+module Main+	( tests+	, main+	) where++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)++tests :: [Suite]+tests =+	[ test_Defaults+	, test_Help+	, test_OptionTypes+	, test_StringParsing+	, test_Tokenize+	, test_Util+	]++main :: IO ()+main = Test.Chell.defaultMain tests
+ tests/OptionsTests/Defaults.hs view
@@ -0,0 +1,192 @@+{-# 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
@@ -0,0 +1,327 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- See license.txt for details+module OptionsTests.Help+	( test_Help+	) where++import           Test.Chell++import           Options.Types+import           Options.Help++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+	]++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+	]++groupInfoHelp :: Maybe GroupInfo+groupInfoHelp = Just (GroupInfo+	{ groupInfoName = "all"+	, groupInfoTitle = "Help Options"+	, groupInfoDescription = "Show all help options."+	})++infoHelpSummary :: [Char] -> [String] -> OptionInfo+infoHelpSummary shorts longs = OptionInfo+	{ optionInfoKey = "main:Options.Help:optHelpSummary"+	, optionInfoShortFlags = shorts+	, optionInfoLongFlags = longs+	, optionInfoDefault = "false"+	, optionInfoUnary = True+	, optionInfoDescription = "Show option summary." +	, optionInfoGroup = groupInfoHelp+	}++infoHelpAll :: OptionInfo+infoHelpAll = OptionInfo+	{ optionInfoKey = "main:Options.Help:optHelpGroup:all"+	, optionInfoShortFlags = []+	, optionInfoLongFlags = ["help-all"]+	, optionInfoDefault = "false"+	, optionInfoUnary = True+	, optionInfoDescription = "Show all help options." +	, optionInfoGroup = groupInfoHelp+	}++test_AddHelpFlags_None :: Suite+test_AddHelpFlags_None = assertions "none" $ do+	let commandDefs = OptionDefinitions+		[ OptionInfo "test.help" ['h'] ["help"] "default" False "" Nothing+		]+		[]+	let helpAdded = addHelpFlags commandDefs+	let OptionDefinitions opts subcmds = helpAdded+	+	$expect (equal opts+		[ infoHelpAll+		, OptionInfo "test.help" ['h'] ["help"] "default" False "" Nothing+		])+	$expect (equal subcmds [])++test_AddHelpFlags_Short :: Suite+test_AddHelpFlags_Short = assertions "short" $ do+	let commandDefs = OptionDefinitions+		[ OptionInfo "test.help" [] ["help"] "default" False "" Nothing+		]+		[]+	let helpAdded = addHelpFlags commandDefs+	let OptionDefinitions opts subcmds = helpAdded+	+	$expect (equal opts+		[ infoHelpSummary ['h'] []+		, infoHelpAll+		, OptionInfo "test.help" [] ["help"] "default" False "" Nothing+		])+	$expect (equal subcmds [])++test_AddHelpFlags_Long :: Suite+test_AddHelpFlags_Long = assertions "long" $ do+	let commandDefs = OptionDefinitions+		[ OptionInfo "test.help" ['h'] [] "default" False "" Nothing+		]+		[]+	let helpAdded = addHelpFlags commandDefs+	let OptionDefinitions opts subcmds = helpAdded+	+	$expect (equal opts+		[ infoHelpSummary [] ["help"]+		, infoHelpAll+		, OptionInfo "test.help" ['h'] [] "default" False "" Nothing+		])+	$expect (equal subcmds [])++test_AddHelpFlags_Both :: Suite+test_AddHelpFlags_Both = assertions "both" $ do+	let commandDefs = OptionDefinitions [] []+	let helpAdded = addHelpFlags commandDefs+	let OptionDefinitions opts subcmds = helpAdded+	+	$expect (equal opts+		[ infoHelpSummary ['h'] ["help"]+		, infoHelpAll+		])+	$expect (equal subcmds [])++test_AddHelpFlags_NoAll :: Suite+test_AddHelpFlags_NoAll = assertions "no-all" $ do+	let commandDefs = OptionDefinitions+		[ OptionInfo "test.help" ['h'] ["help", "help-all"] "default" False "" Nothing+		]+		[]+	let helpAdded = addHelpFlags commandDefs+	let OptionDefinitions opts subcmds = helpAdded+	+	$expect (equal opts+		[ OptionInfo "test.help" ['h'] ["help", "help-all"] "default" False "" Nothing+		])+	$expect (equal subcmds [])++test_AddHelpFlags_Subcommand :: Suite+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 commandDefs = OptionDefinitions+		[]+		[("cmd1", [cmd1_a, cmd1_b])]+	let helpAdded = addHelpFlags commandDefs+	let OptionDefinitions opts subcmds = helpAdded+	+	let helpFoo = OptionInfo+		{ optionInfoKey = "main:Options.Help:optHelpGroup:foo"+		, optionInfoShortFlags = []+		, optionInfoLongFlags = ["help-foo"]+		, optionInfoDefault = "false"+		, optionInfoUnary = True+		, optionInfoDescription = "More Foo Options" +		, optionInfoGroup = Just (GroupInfo+			{ groupInfoName = "all"+			, groupInfoTitle = "Help Options"+			, groupInfoDescription = "Show all help options."+			})+		}+	+	$expect (equal opts+		[ infoHelpSummary ['h'] ["help"]+		, infoHelpAll+		])+	$expect (equal subcmds [("cmd1", [helpFoo, cmd1_a, cmd1_b])])++test_CheckHelpFlag :: Suite+test_CheckHelpFlag = assertions "checkHelpFlag" $ do+	let checkFlag keys = equal (checkHelpFlag (TokensFor [(k, ("-h", "true")) | 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")))++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."+		})+	]+	[ ("cmd1",+		[ OptionInfo "test.cmd1.z" ['z'] ["long-z"] "def" False "z description here" 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."+			})+		])+	]++test_ShowHelpSummary :: Suite+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\+	\\n\+	\Application Options:\n\+	\  -a, --long-a                a description here\n\+	\  --a-looooooooooooong-option description here\n\+	\  --a-loooooooooooooong-option\n\+	\    description here\n\+	\  -b, --long-b                b description here\n\+	\\n\+	\Subcommands:\n\+	\  cmd1\n\+	\  cmd2\n\+	\\n"+	$expect (equalLines expected (helpFor HelpSummary variedOptions Nothing))++test_ShowHelpSummary_Subcommand :: Suite+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\+	\\n\+	\Application Options:\n\+	\  -a, --long-a                a description here\n\+	\  --a-looooooooooooong-option description here\n\+	\  --a-loooooooooooooong-option\n\+	\    description here\n\+	\  -b, --long-b                b description here\n\+	\\n\+	\Options for subcommand \"cmd1\":\n\+	\  -z, --long-z                z description here\n\+	\\n"+	$expect (equalLines expected (helpFor HelpSummary variedOptions (Just "cmd1")))++test_ShowHelpAll :: Suite+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\+	\\n\+	\Grouped options:\n\+	\  -g, --long-g                g description here\n\+	\\n\+	\Application Options:\n\+	\  -a, --long-a                a description here\n\+	\  --a-looooooooooooong-option description here\n\+	\  --a-loooooooooooooong-option\n\+	\    description here\n\+	\  -b, --long-b                b description here\n\+	\\n\+	\Options for subcommand \"cmd1\":\n\+	\  -z, --long-z                z description here\n\+	\\n\+	\Options for subcommand \"cmd2\":\n\+	\  -y, --long-y                y description here\n\+	\  --long-g2                   g2 description here\n\+	\\n"+	$expect (equalLines expected (helpFor HelpAll variedOptions Nothing))++test_ShowHelpAll_Subcommand :: Suite+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\+	\\n\+	\Grouped options:\n\+	\  -g, --long-g                g description here\n\+	\\n\+	\Application Options:\n\+	\  -a, --long-a                a description here\n\+	\  --a-looooooooooooong-option description here\n\+	\  --a-loooooooooooooong-option\n\+	\    description here\n\+	\  -b, --long-b                b description here\n\+	\\n\+	\Options for subcommand \"cmd1\":\n\+	\  -z, --long-z                z description here\n\+	\\n"+	$expect (equalLines expected (helpFor HelpAll variedOptions (Just "cmd1")))++test_ShowHelpGroup :: Suite+test_ShowHelpGroup = assertions "showHelpGroup" $ do+	let expected = "\+	\Grouped options:\n\+	\  -g, --long-g                g description here\n\+	\\n"+	$expect (equalLines expected (helpFor (HelpGroup "group") variedOptions Nothing))++test_ShowHelpGroup_Subcommand :: Suite+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\+	\\n"+	$expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "cmd2")))++test_ShowHelpGroup_SubcommandInvalid :: Suite+test_ShowHelpGroup_SubcommandInvalid = assertions "showHelpGroup-subcommand-invalid" $ do+	let expected = "\+	\Grouped options:\n\+	\  -g, --long-g                g description here\n\+	\\n"+	$expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "noexist")))
+ tests/OptionsTests/OptionTypes.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- See license.txt for details+module OptionsTests.OptionTypes+	( test_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++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+	]++parseValid :: (Show a, Eq a) => OptionType a -> String -> a -> Assertion+parseValid t s expected = equal (optionParser 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++test_Bool :: Suite+test_Bool = assertions "bool" $ do+	$expect (parseValid optionTypeBool "true" True)+	$expect (parseValid optionTypeBool "false" False)+	$expect (parseInvalid optionTypeBool "" "\"\" is not in {\"true\", \"false\"}.")++test_String :: Suite+test_String = assertions "string" $ do+	let valid = parseValid optionTypeString+	let invalid = parseInvalid optionTypeString+	+	$expect (valid "" "")+	$expect (valid "a" "a")+	$expect (valid "\12354" "\12354")+	$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 = assertions "int" $ do+	let valid = parseValid optionTypeInt+	let invalid = parseInvalid optionTypeInt+	+	$expect (valid "-1" (-1 :: Int))+	$expect (valid "1" (1 :: Int))+	$expect (invalid "a" "\"a\" is not an integer.")+	+	let pastMin = show (toInteger (minBound :: Int) - 1)+	let pastMax = show (toInteger (maxBound :: Int) + 1)+	let errBounds = " is not within bounds [" ++ show (minBound :: Int) ++ ":" ++ show (maxBound :: Int) ++ "] of type int."+	+	$expect (invalid pastMin (pastMin ++ errBounds))+	$expect (valid (show (minBound :: Int)) minBound)+	$expect (valid (show (maxBound :: Int)) maxBound)+	$expect (invalid pastMax (pastMax ++ errBounds))++test_Int8 :: Suite+test_Int8 = assertions "int8" $ do+	let valid = parseValid optionTypeInt8+	let invalid = parseInvalid optionTypeInt8+	+	$expect (valid "-1" (-1 :: Int8))+	$expect (valid "1" (1 :: Int8))+	$expect (invalid "a" "\"a\" is not an integer.")+	+	let pastMin = show (toInteger (minBound :: Int8) - 1)+	let pastMax = show (toInteger (maxBound :: Int8) + 1)+	$expect (invalid pastMin "-129 is not within bounds [-128:127] of type int8.")+	$expect (valid (show (minBound :: Int8)) minBound)+	$expect (valid (show (maxBound :: Int8)) maxBound)+	$expect (invalid pastMax "128 is not within bounds [-128:127] of type int8.")++test_Int16 :: Suite+test_Int16 = assertions "int16" $ do+	let valid = parseValid optionTypeInt16+	let invalid = parseInvalid optionTypeInt16+	+	$expect (valid "-1" (-1 :: Int16))+	$expect (valid "1" (1 :: Int16))+	$expect (invalid "a" "\"a\" is not an integer.")+	+	let pastMin = show (toInteger (minBound :: Int16) - 1)+	let pastMax = show (toInteger (maxBound :: Int16) + 1)+	$expect (invalid pastMin "-32769 is not within bounds [-32768:32767] of type int16.")+	$expect (valid (show (minBound :: Int16)) minBound)+	$expect (valid (show (maxBound :: Int16)) maxBound)+	$expect (invalid pastMax "32768 is not within bounds [-32768:32767] of type int16.")++test_Int32 :: Suite+test_Int32 = assertions "int32" $ do+	let valid = parseValid optionTypeInt32+	let invalid = parseInvalid optionTypeInt32+	+	$expect (valid "-1" (-1 :: Int32))+	$expect (valid "1" (1 :: Int32))+	$expect (invalid "a" "\"a\" is not an integer.")+	+	let pastMin = show (toInteger (minBound :: Int32) - 1)+	let pastMax = show (toInteger (maxBound :: Int32) + 1)+	$expect (invalid pastMin "-2147483649 is not within bounds [-2147483648:2147483647] of type int32.")+	$expect (valid (show (minBound :: Int32)) minBound)+	$expect (valid (show (maxBound :: Int32)) maxBound)+	$expect (invalid pastMax "2147483648 is not within bounds [-2147483648:2147483647] of type int32.")++test_Int64 :: Suite+test_Int64 = assertions "int64" $ do+	let valid = parseValid optionTypeInt64+	let invalid = parseInvalid optionTypeInt64+	+	$expect (valid "-1" (-1 :: Int64))+	$expect (valid "1" (1 :: Int64))+	$expect (invalid "a" "\"a\" is not an integer.")+	+	let pastMin = show (toInteger (minBound :: Int64) - 1)+	let pastMax = show (toInteger (maxBound :: Int64) + 1)+	$expect (invalid pastMin "-9223372036854775809 is not within bounds [-9223372036854775808:9223372036854775807] of type int64.")+	$expect (valid (show (minBound :: Int64)) minBound)+	$expect (valid (show (maxBound :: Int64)) maxBound)+	$expect (invalid pastMax "9223372036854775808 is not within bounds [-9223372036854775808:9223372036854775807] of type int64.")++test_Word :: Suite+test_Word = assertions "word" $ do+	let valid = parseValid optionTypeWord+	let invalid = parseInvalid optionTypeWord+	+	let pastMax = show (toInteger (maxBound :: Word) + 1)+	let errBounds = " is not within bounds [0:" ++ show (maxBound :: Word) ++ "] of type word."+	+	$expect (invalid "-1" ("-1" ++ errBounds))+	$expect (valid "0" (0 :: Word))+	$expect (valid "1" (1 :: Word))+	$expect (invalid "a" "\"a\" is not an integer.")+	+	$expect (valid (show (maxBound :: Word)) maxBound)+	$expect (invalid pastMax (pastMax ++ errBounds))++test_Word8 :: Suite+test_Word8 = assertions "word8" $ do+	let valid = parseValid optionTypeWord8+	let invalid = parseInvalid optionTypeWord8+	+	$expect (invalid "-1" "-1 is not within bounds [0:255] of type word8.")+	$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.")++test_Word16 :: Suite+test_Word16 = assertions "word16" $ do+	let valid = parseValid optionTypeWord16+	let invalid = parseInvalid optionTypeWord16+	+	$expect (invalid "-1" "-1 is not within bounds [0:65535] of type word16.")+	$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.")++test_Word32 :: Suite+test_Word32 = assertions "word32" $ do+	let valid = parseValid optionTypeWord32+	let invalid = parseInvalid optionTypeWord32+	+	$expect (invalid "-1" "-1 is not within bounds [0:4294967295] of type word32.")+	$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.")++test_Word64 :: Suite+test_Word64 = assertions "word64" $ do+	let valid = parseValid optionTypeWord64+	let invalid = parseInvalid optionTypeWord64+	+	$expect (invalid "-1" "-1 is not within bounds [0:18446744073709551615] of type word64.")+	$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.")++test_Integer :: Suite+test_Integer = assertions "integer" $ do+	let valid = parseValid optionTypeInteger+	let invalid = parseInvalid optionTypeInteger+	+	$expect (invalid "" "\"\" is not an integer.")+	$expect (valid "-1" (-1 :: Integer))+	$expect (valid "0" (0 :: Integer))+	$expect (valid "1" (1 :: Integer))+	$expect (invalid "a" "\"a\" is not an integer.")++test_Float :: Suite+test_Float = assertions "float" $ do+	let valid = parseValid optionTypeFloat+	let invalid = parseInvalid optionTypeFloat+	+	$expect (valid "-1" (-1 :: Float))+	$expect (valid "0" (0 :: Float))+	$expect (valid "1" (1 :: Float))+	$expect (valid "1.5" (1.5 :: Float))+	$expect (valid "3e5" (3e5 :: Float))+	$expect (invalid "a" "\"a\" is not a number.")++test_Double :: Suite+test_Double = assertions "double" $ do+	let valid = parseValid optionTypeDouble+	let invalid = parseInvalid optionTypeDouble+	+	$expect (valid "-1" (-1 :: Double))+	$expect (valid "0" (0 :: Double))+	$expect (valid "1" (1 :: Double))+	$expect (valid "1.5" (1.5 :: Double))+	$expect (valid "3e5" (3e5 :: Double))+	$expect (invalid "a" "\"a\" is not a number.")++test_Maybe :: Suite+test_Maybe = assertions "maybe" $ do+	let t = optionTypeMaybe optionTypeInt+	let valid = parseValid t+	let invalid = parseInvalid t+	+	$expect (valid "" Nothing)+	$expect (valid "1" (Just 1))+	$expect (invalid "a" "\"a\" is not an integer.")++test_List :: Suite+test_List = assertions "list" $ do+	let t = optionTypeList ',' optionTypeInt+	let valid = parseValid t+	let invalid = parseInvalid t+	+	$expect (valid "" [])+	$expect (valid "1" [1])+	$expect (valid "1,2,3" [1, 2, 3])+	$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 = assertions "set" $ do+	let t = optionTypeSet ',' optionTypeInt+	let valid = parseValid t+	let invalid = parseInvalid t+	+	$expect (valid "" Set.empty)+	$expect (valid "1" (Set.fromList [1]))+	$expect (valid "1,2,3" (Set.fromList [1, 2, 3]))+	$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 = assertions "map" $ do+	let t = optionTypeMap ',' '=' optionTypeInt optionTypeInt+	let valid = parseValid t+	let invalid = parseInvalid t+	+	$expect (valid "" Map.empty)+	$expect (valid "1=100" (Map.fromList [(1, 100)]))+	$expect (valid "1=100,2=200,3=300" (Map.fromList [(1, 100), (2, 200), (3, 300)]))+	$expect (valid "1=100,2=200,1=300" (Map.fromList [(1, 300), (2, 200)]))+	$expect (invalid "a=1" "\"a\" is not an integer.")+	$expect (invalid "1=a" "\"a\" is not an integer.")+	$expect (invalid "1=" "\"\" is not an integer.")+	$expect (invalid "1" "Map item \"1\" has no value.")++data TestEnum = Enum1 | Enum2 | Enum3+	deriving (Enum, Eq, Show)++test_Enum :: Suite+test_Enum = assertions "enum" $ do+	let t = optionTypeEnum ''TestEnum+		[ ("e1", Enum1)+		, ("e2", Enum2)+		, ("e3", Enum3)+		]+	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\"}.")
+ tests/OptionsTests/StringParsing.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- See license.txt for details+module OptionsTests.StringParsing+	( test_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           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+		})+	)++windowsBuild :: Bool+#if defined(CABAL_OS_WINDOWS)+windowsBuild = True+#else+windowsBuild = False+#endif++test_StringParsing :: Suite+test_StringParsing = suite "string-parsing"+	[ test_Defaults+	, test_Ascii+	, test_UnicodeValid+	, skipIf windowsBuild test_UnicodeInvalid+	]++test_Defaults :: Suite+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 = assertions "ascii" $ do+	let parsed = parseOptions ["--string=a", "--text=a", "--path=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 = 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"]+#else+	let parsed = parseOptions ["--string=\12354", "--text=\12354", "--path=\12354/b/c"]+#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 = assertions "unicode-invalid" $ do+#if __GLASGOW_HASKELL__ >= 704+	let parsed = parseOptions ["--string=\56507", "--text=\56507", "--path=\12354/\56507"]+	let expectedString = "\56507"+	let expectedText = "\65533"+#elif __GLASGOW_HASKELL__ >= 702+	let parsed = parseOptions ["--string=\61371", "--text=\61371", "--path=\12354/\61371"]+	let expectedString = "\61371"+	let expectedText = "\61371"+#else+	let parsed = parseOptions ["--string=\187", "--text=\187", "--path=\227\129\130/\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
@@ -0,0 +1,323 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- See license.txt for details+module OptionsTests.Tokenize+	( test_Tokenize+	) where++import           Test.Chell++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+	]++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+	]+	[]++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+	]+	[ ("sub1",+		[ OptionInfo "sub.d" ['d'] ["long-d"] "default" False "" Nothing+		, OptionInfo "sub.e" ['e'] ["long-e"] "default" True "" Nothing+		])+	, ("sub2",+		[ OptionInfo "sub.d" ['d'] ["long-d"] "default" True "" Nothing+		, OptionInfo "sub.e" ['e'] ["long-e"] "default" True "" Nothing+		])+	]++unicodeDefs :: OptionDefinitions ()+unicodeDefs = OptionDefinitions+	[ OptionInfo "test.a" ['\12354'] ["long-\12354"] "default" False "" Nothing+	]+	[]++test_Empty :: Suite+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)+	$expect (equal [] args)++test_NoFlag :: Suite+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)+	$expect (equal ["-", "foo", "bar"] args)++test_ShortFlag :: Suite+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)+		$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)+		$expect (equal ["bar"] args)++test_ShortFlagUnknown :: Suite+test_ShortFlagUnknown = assertions "short-flag-unknown" $ do+	let (subcmd, eTokens) = tokenize commandDefs ["-c", "foo", "bar"]+	$expect (equal Nothing subcmd)+	$assert (left eTokens)+	+	let Left err = eTokens+	$expect (equal "Unknown flag -c" err)++test_ShortFlagMissing :: Suite+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)++test_ShortFlagUnary :: Suite+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)+		$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)+		$expect (equal ["foo", "bar"] args)++test_ShortFlagDuplicate :: Suite+test_ShortFlagDuplicate = assertions "short-flag-duplicate" $ do+	do+		let (subcmd, eTokens) = tokenize commandDefs ["-x", "-x"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Multiple values for flag -x were provided." err)+	do+		let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-a", "foo"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Multiple values for flag -a were provided." err)+	do+		let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-afoo"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Multiple values for flag -a were provided." err)++test_LongFlag :: Suite+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)+		$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)+		$expect (equal ["bar"] args)++test_LongFlagUnknown :: Suite+test_LongFlagUnknown = assertions "long-flag-unknown" $ do+	do+		let (subcmd, eTokens) = tokenize commandDefs ["--long-c", "foo", "bar"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Unknown flag --long-c" err)+	do+		let (subcmd, eTokens) = tokenize commandDefs ["--long-c=foo", "bar"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Unknown flag --long-c" err)++test_LongFlagMissing :: Suite+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)++test_LongFlagUnary :: Suite+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)+		$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)+		$expect (equal ["bar"] args)++test_LongFlagDuplicate :: Suite+test_LongFlagDuplicate = assertions "long-flag-duplicate" $ do+	do+		let (subcmd, eTokens) = tokenize commandDefs ["-x", "--long-x"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Multiple values for flag --long-x were provided." err)+	do+		let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a", "foo"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Multiple values for flag --long-a were provided." err)+	do+		let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a=foo"]+		$expect (equal Nothing subcmd)+		$assert (left eTokens)+		+		let Left err = eTokens+		$expect (equal "Multiple values for flag --long-a were provided." err)++test_EndFlags :: Suite+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)+	$expect (equal ["foo", "-a", "bar"] args)++test_Subcommand :: Suite+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)+		$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)+		$expect (equal ["foo", "bar"] args)++test_SubcommandUnknown:: Suite+test_SubcommandUnknown = assertions "subcommand-unknown" $ do+	let (subcmd, eTokens) = tokenize subcommandDefs ["foo"]+	$expect (equal Nothing subcmd)+	$assert (left eTokens)+	+	let Left err = eTokens+	$expect (equal "Unknown subcommand \"foo\"." err)++test_Unicode :: Suite+test_Unicode = assertions "unicode" $ do+#if defined(OPTIONS_ENCODING_UTF8)+	let shortArgs = ["-\227\129\130", "foo", "bar"]+	let longArgs = ["--long-\227\129\130=foo", "bar"]+#else+	let shortArgs = ["-\12354", "foo", "bar"]+	let longArgs = ["--long-\12354=foo", "bar"]+#endif+	do+		let (subcmd, eTokens) = tokenize unicodeDefs shortArgs+		$expect (equal Nothing subcmd)+		case eTokens of+			Left err -> error err+			Right _ -> return ()+		$assert (right eTokens)+		+		let Right (TokensFor tokens args) = eTokens+		$expect (equal [("test.a", ("-\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)+		$expect (equal ["bar"] args)
+ tests/OptionsTests/Util.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- See license.txt for details+module OptionsTests.Util+	( test_Util+	) where++#if defined(OPTIONS_ENCODING_UTF8)+import           Data.Bits+import qualified Data.ByteString.Char8 as Char8+import           Data.Char (chr, ord)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import           Test.Chell.QuickCheck+import           Test.QuickCheck (Property, forAll)+import           Test.QuickCheck.Gen+#endif++import           Test.Chell++import           Options.Util++test_Util :: Suite+test_Util = suite "util"+	[ test_ValidFieldName+	, test_ValidShortFlag+	, test_ValidLongFlag+	, test_HasDuplicates+#if defined(OPTIONS_ENCODING_UTF8)+	, property "decodeUtf8" prop_DecodeUtf8+#endif+	]++test_ValidFieldName :: Suite+test_ValidFieldName = assertions "validFieldName" $ do+	$expect (validFieldName "a")+	$expect (validFieldName "abc")+	$expect (validFieldName "_abc_")+	$expect (validFieldName "abc'")+	$expect (validFieldName "\12354")+	$expect (not (validFieldName ""))+	$expect (not (validFieldName "'a"))+	$expect (not (validFieldName "a b"))+	$expect (not (validFieldName "Ab"))++test_ValidShortFlag :: Suite+test_ValidShortFlag = assertions "validShortFlag" $ do+	$expect (validShortFlag 'a')+	$expect (validShortFlag 'A')+	$expect (validShortFlag '0')+	$expect (validShortFlag '\12354')+	$expect (not (validShortFlag ' '))+	$expect (not (validShortFlag '-'))++test_ValidLongFlag :: Suite+test_ValidLongFlag = assertions "validLongFlag" $ do+	$expect (validLongFlag "a")+	$expect (validLongFlag "A")+	$expect (validLongFlag "abc")+	$expect (validLongFlag "0")+	$expect (validLongFlag "012")+	$expect (validLongFlag "a-b")+	$expect (validLongFlag "a_b")+	$expect (validLongFlag "\12354bc")+	$expect (not (validLongFlag ""))+	$expect (not (validLongFlag "a b"))+	$expect (not (validLongFlag "a+b"))+	$expect (not (validLongFlag "-"))+	$expect (not (validLongFlag "--"))++test_HasDuplicates :: Suite+test_HasDuplicates = assertions "hasDuplicates" $ do+	$expect (not (hasDuplicates ([] :: [Char])))+	$expect (not (hasDuplicates ['a', 'b']))+	$expect (hasDuplicates ['a', 'b', 'a'])++#if defined(OPTIONS_ENCODING_UTF8)+prop_DecodeUtf8 :: Property+prop_DecodeUtf8 = forAll example prop where+	example = do+		chunks <- listOf genChunk+		let utf = concat [x | (x, _) <- chunks]+		let chars = concat [x | (_, x) <- chunks]+		return (Char8.pack utf, chars)+	genChunk = do+		unichr <- genUnichar+		let utf = Char8.unpack (Text.encodeUtf8 (Text.singleton unichr))+		nBytes <- choose (1, length utf)+		let truncUtf = take nBytes utf+		return $ if nBytes == length utf+			then (utf, [unichr])+			else (truncUtf, map (\c -> chr (ord c + 0xDC00)) truncUtf)+	prop (bytes, expected) = decodeUtf8 bytes == expected++genUnichar :: Gen Char+genUnichar = chr `fmap` excluding reserved (oneof planes) where+	excluding :: [a -> Bool] -> Gen a -> Gen a+	excluding bad gen = loop where+		loop = do+			x <- gen+			if or (map ($ x) bad)+				then loop+				else return x+	+	reserved = [lowSurrogate, highSurrogate, noncharacter]+	lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF+	highSurrogate c = c >= 0xD800 && c <= 0xDBFF+	noncharacter c = masked == 0xFFFE || masked == 0xFFFF where+		masked = c .&. 0xFFFF+	+	ascii = choose (0,0x7F)+	plane0 = choose (0xF0, 0xFFFF)+	plane1 = oneof [ choose (0x10000, 0x10FFF)+	               , choose (0x11000, 0x11FFF)+	               , choose (0x12000, 0x12FFF)+	               , choose (0x13000, 0x13FFF)+	               , choose (0x1D000, 0x1DFFF)+	               , choose (0x1F000, 0x1FFFF)+	               ]+	plane2 = oneof [ choose (0x20000, 0x20FFF)+	               , choose (0x21000, 0x21FFF)+	               , choose (0x22000, 0x22FFF)+	               , choose (0x23000, 0x23FFF)+	               , choose (0x24000, 0x24FFF)+	               , choose (0x25000, 0x25FFF)+	               , choose (0x26000, 0x26FFF)+	               , choose (0x27000, 0x27FFF)+	               , choose (0x28000, 0x28FFF)+	               , choose (0x29000, 0x29FFF)+	               , choose (0x2A000, 0x2AFFF)+	               , choose (0x2B000, 0x2BFFF)+	               , choose (0x2F000, 0x2FFFF)+	               ]+	plane14 = choose (0xE0000, 0xE0FFF)+	planes = [ascii, plane0, plane1, plane2, plane14]+#endif
+ tests/options-tests.cabal view
@@ -0,0 +1,39 @@+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+