    {-# 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