    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE TypeSynonymInstances #-}

    -- |
    -- Module: Options
    -- License: MIT
    --
    -- The @options@ package lets library and application developers easily work
    -- with command-line options.
    --
    -- The following example is a full program that can accept two options,
    -- @--message@ and @--quiet@:
    --
    -- @
    --import Control.Applicative
    --import Options
    --
    --data MainOptions = MainOptions
    --    { optMessage :: String
    --    , optQuiet :: Bool
    --    }
    --
    --instance 'Options' MainOptions where
    --    'defineOptions' = pure MainOptions
    --        \<*\> 'simpleOption' \"message\" \"Hello world!\"
    --            \"A message to show the user.\"
    --        \<*\> 'simpleOption' \"quiet\" False
    --            \"Whether to be quiet.\"
    --
    --main :: IO ()
    --main = 'runCommand' $ \\opts args -> do
    --    if optQuiet opts
    --        then return ()
    --        else putStrLn (optMessage opts)
    -- @
    --
    -- >$ ./hello
    -- >Hello world!
    -- >$ ./hello --message='ciao mondo'
    -- >ciao mondo
    -- >$ ./hello --quiet
    -- >$
    --
    -- In addition, this library will automatically create documentation options
    -- such as @--help@ and @--help-all@:
    --
    -- >$ ./hello --help
    -- >Help Options:
    -- >  -h, --help
    -- >    Show option summary.
    -- >  --help-all
    -- >    Show all help options.
    -- >
    -- >Application Options:
    -- >  --message :: text
    -- >    A message to show the user.
    -- >    default: "Hello world!"
    -- >  --quiet :: bool
    -- >    Whether to be quiet.
    -- >    default: false
    module Options
            (
            -- * Defining options
              Options(..)
            , defaultOptions
            , simpleOption
            , DefineOptions
            , SimpleOptionType(..)

            -- * Defining subcommands
            , Subcommand
            , subcommand

            -- * Running main with options
            , runCommand
            , runSubcommand

            -- * Parsing argument lists
            , Parsed
            , parsedError
            , parsedHelp

            -- ** Parsing options
            , ParsedOptions
            , parsedOptions
            , parsedArguments
            , parseOptions

            -- ** Parsing sub-commands
            , ParsedSubcommand
            , parsedSubcommand
            , parseSubcommand

            -- * Advanced option definitions
            , OptionType
            , defineOption
            , Option
            , optionShortFlags
            , optionLongFlags
            , optionDefault
            , optionDescription
            , optionGroup

            -- ** Option groups
            , Group
            , group
            , groupName
            , groupTitle
            , groupDescription

            -- * Option types
            , optionType_bool

            , optionType_string

            , optionType_int
            , optionType_int8
            , optionType_int16
            , optionType_int32
            , optionType_int64
            , optionType_word
            , optionType_word8
            , optionType_word16
            , optionType_word32
            , optionType_word64
            , optionType_integer

            , optionType_float
            , optionType_double

            , optionType_maybe
            , optionType_list
            , optionType_set
            , optionType_map
            , optionType_enum

            -- ** Custom option types
            , optionType
            , optionTypeName
            , optionTypeDefault
            , optionTypeParse
            , optionTypeShow
            , optionTypeUnary
            , optionTypeMerge
            ) where

    import           Control.Applicative
    import           Control.Monad (forM_)
    import           Control.Monad.Error (ErrorT, runErrorT, throwError)
    import           Control.Monad.IO.Class (liftIO, MonadIO)
    import           Data.Functor.Identity
    import           Data.Int
    import           Data.List (intercalate)
    import qualified Data.Map as Map
    import           Data.Maybe (isJust)
    import qualified Data.Set as Set
    import           Data.Word
    import qualified System.Environment
    import           System.Exit (exitFailure, exitSuccess)
    import           System.IO (hPutStr, hPutStrLn, stderr, stdout)

    import           Options.Help
    import           Options.Tokenize
    import           Options.Types
    import           Options.Util (mapEither)

    -- | Options are defined together in a single data type, which will be an
    -- instance of 'Options'.
    --
    -- See 'defineOptions' for details on defining instances of 'Options'.
    class Options opts where
            -- | Defines the structure and metadata of the options in this type,
            -- including their types, flag names, and documentation.
            --
            -- Options with a basic type and a single flag name may be defined
            -- with 'simpleOption'. Options with more complex requirements may
            -- be defined with 'defineOption'.
            --
            -- Non-option fields in the type may be set using applicative functions
            -- such as 'pure'.
            --
            -- Options may be included from another type by using a nested call to
            -- 'defineOptions'.
            --
            -- Library authors are encouraged to aggregate their options into a
            -- few top-level types, so application authors can include it
            -- easily in their own option definitions.
            defineOptions :: DefineOptions opts

    data DefineOptions a = DefineOptions a (Integer -> (Integer, [OptionInfo])) (Integer -> Map.Map OptionKey [Token] -> Either String (Integer, a))

    instance Functor DefineOptions where
            fmap fn (DefineOptions defaultValue getInfo parse) = DefineOptions (fn defaultValue) getInfo (\key tokens -> case parse key tokens of
                    Left err -> Left err
                    Right (key', a) -> Right (key', fn a))

    instance Applicative DefineOptions where
            pure a = DefineOptions a (\key -> (key, [])) (\key _ -> Right (key, a))
            (DefineOptions acc_default acc_getInfo acc_parse) <*> (DefineOptions defaultValue getInfo parse) = DefineOptions
                    (acc_default defaultValue)
                    (\key -> case acc_getInfo key of
                            (key', infos) -> case getInfo key' of
                                    (key'', infos') -> (key'', infos ++ infos'))
                    (\key tokens -> case acc_parse key tokens of
                            Left err -> Left err
                            Right (key', fn) -> case parse key' tokens of
                                    Left err -> Left err
                                    Right (key'', a) -> Right (key'', fn a))

    -- | An options value containing only the default values for each option.
    -- This is equivalent to the options value when parsing an empty argument
    -- list.
    defaultOptions :: Options opts => opts
    defaultOptions = case defineOptions of
            (DefineOptions def _ _) -> def

    -- | An option's type determines how the option will be parsed, and which
    -- Haskell type the parsed value will be stored as. There are many types
    -- available, covering most basic types and a few more advanced types.
    data OptionType val = OptionType
            {
            -- | The name of this option type; used in @--help@ output.
              optionTypeName :: String

            -- | The default value for options of this type. This will be used
            -- if 'optionDefault' is not set when defining the option.
            , optionTypeDefault :: val

            -- | Try to parse the given string to an option value. If parsing
            -- fails, an error message will be returned.
            , optionTypeParse :: String -> Either String val

            -- | Format the value for display; used in @--help@ output.
            , optionTypeShow :: val -> String

            -- | If not Nothing, then options of this type may be set by a unary
            -- flag. The option will be parsed as if the given value were set.
            , optionTypeUnary :: Maybe val

            -- | If not Nothing, then options of this type may be set with repeated
            -- flags. Each flag will be parsed with 'optionTypeParse', and the
            -- resulting parsed values will be passed to this function for merger
            -- into the final value.
            , optionTypeMerge :: Maybe ([val] -> val)
            }

    -- | Define an option group with the given name and title. Use
    -- 'groupDescription' to add additional descriptive text, if needed.
    group :: String -- ^ Name
          -> String -- ^ Title; see 'groupTitle'.
          -> String -- ^ Description; see 'groupDescription'.
          -> Group
    group = Group

    -- | Define a new option type with the given name, default, and behavior.
    optionType :: String -- ^ Name
               -> val -- ^ Default value
               -> (String -> Either String val) -- ^ Parser
               -> (val -> String) -- ^ Formatter
               -> OptionType val
    optionType name def parse show' = OptionType name def parse show' Nothing Nothing

    class SimpleOptionType a where
            simpleOptionType :: OptionType a

    instance SimpleOptionType Bool where
            simpleOptionType = optionType_bool

    -- | Store an option as a @'Bool'@. The option's value must be either
    -- @\"true\"@ or @\"false\"@.
    --
    -- Boolean options are unary, which means that their value is optional when
    -- specified on the command line. If a flag is present, the option is set to
    -- True.
    --
    -- >$ ./app -q
    -- >$ ./app --quiet
    --
    -- Boolean options may still be specified explicitly by using long flags with
    -- the @--flag=value@ format. This is the only way to set a unary flag to
    -- @\"false\"@.
    --
    -- >$ ./app --quiet=true
    -- >$ ./app --quiet=false
    optionType_bool :: OptionType Bool
    optionType_bool = (optionType "bool" False parseBool (\x -> if x then "true" else "false"))
            { optionTypeUnary = Just True
            }

    parseBool :: String -> Either String Bool
    parseBool s = case s of
            "true" -> Right True
            "false" -> Right False
            _ -> Left (show s ++ " is not in {\"true\", \"false\"}.")

    instance SimpleOptionType String where
            simpleOptionType = optionType_string

    -- | Store an option value as a @'String'@. The value is decoded to Unicode
    -- first, if needed. The value may contain non-Unicode bytes, in which case
    -- they will be stored using GHC 7.4's encoding for mixed-use strings.
    optionType_string :: OptionType String
    optionType_string = optionType "text" "" Right show

    instance SimpleOptionType Integer where
            simpleOptionType = optionType_integer

    -- | Store an option as an @'Integer'@. The option value must be an integer.
    -- There is no minimum or maximum value.
    optionType_integer :: OptionType Integer
    optionType_integer = optionType "integer" 0 parseInteger show

    parseInteger :: String -> Either String Integer
    parseInteger s = parsed where
            parsed = if valid
                    then Right (read s)
                    else Left (show s ++ " is not an integer.")
            valid = case s of
                    [] -> False
                    '-':s' -> allDigits s'
                    _ -> allDigits s
            allDigits = all (\c -> c >= '0' && c <= '9')

    parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a
    parseBoundedIntegral label = parse where
            getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer)
            getBounds _ min' max' = (toInteger min', toInteger max')

            (minInt, maxInt) = getBounds parse minBound maxBound

            parse s = case parseInteger s of
                    Left err -> Left err
                    Right int -> if int < minInt || int > maxInt
                            then Left (show int ++ " is not within bounds [" ++ show minInt ++ ":" ++ show maxInt ++ "] of type " ++ label ++ ".")
                            else Right (fromInteger int)

    optionTypeBoundedInt :: (Bounded a, Integral a, Show a) => String -> OptionType a
    optionTypeBoundedInt tName = optionType tName 0 (parseBoundedIntegral tName) show

    instance SimpleOptionType Int where
            simpleOptionType = optionType_int

    -- | Store an option as an @'Int'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionType_int :: OptionType Int
    optionType_int = optionTypeBoundedInt "int"

    instance SimpleOptionType Int8 where
            simpleOptionType = optionType_int8

    -- | Store an option as an @'Int8'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionType_int8 :: OptionType Int8
    optionType_int8 = optionTypeBoundedInt "int8"

    instance SimpleOptionType Int16 where
            simpleOptionType = optionType_int16

    -- | Store an option as an @'Int16'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionType_int16 :: OptionType Int16
    optionType_int16 = optionTypeBoundedInt "int16"

    instance SimpleOptionType Int32 where
            simpleOptionType = optionType_int32

    -- | Store an option as an @'Int32'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionType_int32 :: OptionType Int32
    optionType_int32 = optionTypeBoundedInt "int32"

    instance SimpleOptionType Int64 where
            simpleOptionType = optionType_int64

    -- | Store an option as an @'Int64'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionType_int64 :: OptionType Int64
    optionType_int64 = optionTypeBoundedInt "int64"

    instance SimpleOptionType Word where
            simpleOptionType = optionType_word

    -- | Store an option as a @'Word'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionType_word :: OptionType Word
    optionType_word = optionTypeBoundedInt "uint"

    instance SimpleOptionType Word8 where
            simpleOptionType = optionType_word8

    -- | Store an option as a @'Word8'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionType_word8 :: OptionType Word8
    optionType_word8 = optionTypeBoundedInt "uint8"

    instance SimpleOptionType Word16 where
            simpleOptionType = optionType_word16

    -- | Store an option as a @'Word16'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionType_word16 :: OptionType Word16
    optionType_word16 = optionTypeBoundedInt "uint16"

    instance SimpleOptionType Word32 where
            simpleOptionType = optionType_word32

    -- | Store an option as a @'Word32'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionType_word32 :: OptionType Word32
    optionType_word32 = optionTypeBoundedInt "uint32"

    instance SimpleOptionType Word64 where
            simpleOptionType = optionType_word64

    -- | Store an option as a @'Word64'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionType_word64 :: OptionType Word64
    optionType_word64 = optionTypeBoundedInt "uint64"

    instance SimpleOptionType Float where
            simpleOptionType = optionType_float

    -- | Store an option as a @'Float'@. The option value must be a number. Due to
    -- the imprecision of floating-point math, the stored value might not exactly
    -- match the user's input. If the user's input is out of range for the
    -- @'Float'@ type, it will be stored as @Infinity@ or @-Infinity@.
    optionType_float :: OptionType Float
    optionType_float = optionType "float32" 0 parseFloat show

    instance SimpleOptionType Double where
            simpleOptionType = optionType_double

    -- | Store an option as a @'Double'@. The option value must be a number. Due to
    -- the imprecision of floating-point math, the stored value might not exactly
    -- match the user's input. If the user's input is out of range for the
    -- @'Double'@ type, it will be stored as @Infinity@ or @-Infinity@.
    optionType_double :: OptionType Double
    optionType_double = optionType "float64" 0 parseFloat show

    parseFloat :: Read a => String -> Either String a
    parseFloat s = case reads s of
            [(x, "")] -> Right x
            _ -> Left (show s ++ " is not a number.")

    instance SimpleOptionType a => SimpleOptionType (Maybe a) where
            simpleOptionType = optionType_maybe simpleOptionType

    -- | Store an option as a @'Maybe'@ of another type. The value will be
    -- @Nothing@ if the option is set to an empty string.
    optionType_maybe :: OptionType a -> OptionType (Maybe a)
    optionType_maybe t = maybeT { optionTypeUnary = unary } where
            maybeT = optionType name Nothing (parseMaybe t) (showMaybe t)
            name = "maybe<" ++ optionTypeName t ++ ">"
            unary = case optionTypeUnary t of
                    Nothing -> Nothing
                    Just val -> Just (Just val)

    parseMaybe :: OptionType val -> String -> Either String (Maybe val)
    parseMaybe t s = case s of
            "" -> Right Nothing
            _ -> case optionTypeParse t s of
                    Left err -> Left err
                    Right a -> Right (Just a)

    showMaybe :: OptionType val -> Maybe val -> String
    showMaybe _ Nothing = ""
    showMaybe t (Just x) = optionTypeShow t x

    -- | Store an option as a @'Set.Set'@, using another option type for the
    -- elements. The separator should be a character that will not occur within
    -- the values, such as a comma or semicolon.
    --
    -- Duplicate elements in the input are permitted.
    optionType_set :: Ord a
                   => Char -- ^ Element separator
                   -> OptionType a -- ^ Element type
                   -> OptionType (Set.Set a)
    optionType_set sep t = optionType name Set.empty parseSet showSet where
            name = "set<" ++ optionTypeName t ++ ">"
            parseSet s = case parseList (optionTypeParse t) (split sep s) of
                    Left err -> Left err
                    Right xs -> Right (Set.fromList xs)
            showSet xs = intercalate [sep] (map (optionTypeShow t) (Set.toList xs))

    -- | Store an option as a 'Map.Map', using other option types for the keys and
    -- values.
    --
    -- The item separator is used to separate key/value pairs from eachother. It
    -- should be a character that will not occur within either the keys or values.
    --
    -- The value separator is used to separate the key from the value. It should
    -- be a character that will not occur within the keys. It may occur within the
    -- values.
    --
    -- Duplicate keys in the input are permitted. The final value for each key is
    -- stored.
    optionType_map :: Ord k
                   => Char -- ^ Item separator
                   -> Char -- ^ Key/Value separator
                   -> OptionType k -- ^ Key type
                   -> OptionType v -- ^ Value type
                   -> OptionType (Map.Map k v)
    optionType_map itemSep keySep kt vt = optionType name Map.empty parser showMap where
            name = "map<" ++ optionTypeName kt ++ "," ++ optionTypeName vt ++ ">"
            parser s = parseMap keySep (optionTypeParse kt) (optionTypeParse vt) (split itemSep s)
            showMap m = intercalate [itemSep] (map showItem (Map.toList m))
            showItem (k, v) = optionTypeShow kt k ++ [keySep] ++ optionTypeShow vt v

    parseList :: (String -> Either String a) -> [String] -> Either String [a]
    parseList p = loop where
            loop [] = Right []
            loop (x:xs) = case p x of
                    Left err -> Left err
                    Right v -> case loop xs of
                            Left err -> Left err
                            Right vs -> Right (v:vs)

    parseMap :: Ord k => Char -> (String -> Either String k) -> (String -> Either String v) -> [String] -> Either String (Map.Map k v)
    parseMap keySep pKey pVal = parsed where
            parsed strs = case parseList pItem strs of
                    Left err -> Left err
                    Right xs -> Right (Map.fromList xs)
            pItem s = case break (== keySep) s of
                    (sKey, valAndSep) -> case valAndSep of
                            [] -> Left ("Map item " ++ show s ++ " has no value.")
                            _ : sVal -> case pKey sKey of
                                    Left err -> Left err
                                    Right key -> case pVal sVal of
                                            Left err -> Left err
                                            Right val -> Right (key, val)

    split :: Char -> String -> [String]
    split _ [] = []
    split sep s0 = loop s0 where
            loop s = let
                    (chunk, rest) = break (== sep) s
                    cont = chunk : loop (tail rest)
                    in if null rest then [chunk] else cont

    -- | Store an option as a list, using another option type for the elements.
    -- The separator should be a character that will not occur within the values,
    -- such as a comma or semicolon.
    optionType_list :: Char -- ^ Element separator
                    -> OptionType a -- ^ Element type
                    -> OptionType [a]
    optionType_list sep t = optionType name [] parser shower where
            name =  "list<" ++ optionTypeName t ++ ">"
            parser s = parseList (optionTypeParse t) (split sep s)
            shower xs = intercalate [sep] (map (optionTypeShow t) xs)

    -- | Store an option as one of a set of possible values. The type must be a
    -- bounded enumeration, and the type's 'Show' instance will be used to
    -- implement the parser.
    --
    -- This is a simplistic implementation, useful for quick scripts. Users with
    -- more complex requirements for enum parsing are encouraged to define their
    -- own option types using 'optionType'.
    --
    -- @
    --data Action = Hello | Goodbye
    --    deriving (Bounded, Enum, Show)
    --
    --data MainOptions = MainOptions { optAction :: Action }
    --
    --instance 'Options' MainOptions where
    --    'defineOptions' = pure MainOptions
    --        \<*\> 'defineOption' (optionType_enum \"action\") (\\o -> o
    --            { 'optionLongFlags' = [\"action\"]
    --            , 'optionDefault' = Hello
    --            })
    --
    --main = 'runCommand' $ \\opts args -> do
    --    putStrLn (\"Running action \" ++ show (optAction opts))
    -- @
    --
    -- >$ ./app
    -- >Running action Hello
    -- >$ ./app --action=Goodbye
    -- >Running action Goodbye
    optionType_enum :: (Bounded a, Enum a, Show a)
                    => String -- ^ Option type name
                    -> OptionType a
    optionType_enum tName = optionType tName minBound parseEnum show where
            values = Map.fromList [(show x, x) | x <- enumFrom minBound]
            setString = "{" ++ intercalate ", " (map show (Map.keys values)) ++ "}"
            parseEnum s = case Map.lookup s values of
                    Nothing -> Left (show s ++ " is not in " ++ setString ++ ".")
                    Just x -> Right x

    -- | Defines a new option in the current options type.
    --
    simpleOption :: SimpleOptionType a
                 => String -- long flag
                 -> a -- default value
                 -> String -- description
                 -> DefineOptions a
    simpleOption flag def desc = defineOption simpleOptionType (\o -> o
            { optionLongFlags = [flag]
            , optionDefault = def
            , optionDescription = desc
            })

    -- | Defines a new option in the current options type.
    --
    -- All options must have one or more /flags/. Options may also have a
    -- default value, a description, and a group.
    --
    -- The /flags/ are how the user specifies an option on the command line. Flags
    -- may be /short/ or /long/. See 'optionShortFlags' and 'optionLongFlags' for
    -- details.
    --
    -- @
    --'defineOption' 'optionType_word16' (\\o -> o
    --    { 'optionLongFlags' = [\"port\"]
    --    , 'optionDefault' = 80
    --    })
    -- @
    defineOption :: OptionType a -> (Option a -> Option a) -> DefineOptions a
    defineOption t fn = DefineOptions (optionDefault opt) getInfo parser where
            opt = fn (Option
                    { optionShortFlags = []
                    , optionLongFlags = []
                    , optionDefault = optionTypeDefault t
                    , optionDescription = ""
                    , optionGroup = Nothing
                    , optionLocation = Nothing
                    })

            getInfo key = (key+1, [OptionInfo
                    { optionInfoKey = OptionKeyGenerated key
                    , optionInfoShortFlags = optionShortFlags opt
                    , optionInfoLongFlags = optionLongFlags opt
                    , optionInfoDefault = optionTypeShow t (optionDefault opt)
                    , optionInfoDescription = optionDescription opt
                    , optionInfoGroup = optionGroup opt
                    , optionInfoLocation = optionLocation opt
                    , optionInfoTypeName = optionTypeName t
                    , optionInfoUnary = isJust (optionTypeUnary t)
                    , optionInfoUnaryOnly = False
                    }])

            -- parseToken :: Token -> Either String val
            parseToken tok = case tok of
                    TokenUnary flagName -> case optionTypeUnary t of
                            Nothing -> Left ("The flag " ++ flagName ++ " requires an argument.")
                            Just val -> Right val
                    Token flagName rawValue -> case optionTypeParse t rawValue of
                            Left err -> Left ("Value for flag " ++ flagName ++ " is invalid: " ++ err)
                            Right val -> Right val

            parser key tokens = case Map.lookup (OptionKeyGenerated key) tokens of
                    Nothing -> Right (key+1, optionDefault opt)
                    Just toks -> case toks of
                            -- shouldn't happen, but lets do something graceful anyway.
                            [] -> Right (key+1, optionDefault opt)
                            [tok] -> case parseToken tok of
                                    Left err -> Left err
                                    Right val -> Right (key+1, val)
                            _ -> case optionTypeMerge t of
                                    Nothing -> Left ("Multiple values for flag: " ++ showMultipleFlagValues toks)
                                    Just appendFn -> case mapEither parseToken toks of
                                            Left err -> Left err
                                            Right vals -> Right (key+1, appendFn vals)

    showMultipleFlagValues :: [Token] -> String
    showMultipleFlagValues = intercalate " " . map showToken where
            showToken (TokenUnary flagName) = flagName
            showToken (Token flagName rawValue) = show (flagName ++ "=" ++ rawValue)

    data Option a = Option
            {
            -- | Short flags are a single character. When entered by a user,
            -- they are preceded by a dash and possibly other short flags.
            --
            -- Short flags must be a letter or a number.
            --
            -- Example: An option with @optionShortFlags = [\'p\']@ may be set using:
            --
            -- >$ ./app -p 443
            -- >$ ./app -p443
              optionShortFlags :: [Char]

            -- | Long flags are multiple characters. When entered by a user, they
            -- are preceded by two dashes.
            --
            -- Long flags may contain letters, numbers, @\'-\'@, and @\'_\'@.
            --
            -- Example: An option with @optionLongFlags = [\"port\"]@ may be set using:
            --
            -- >$ ./app --port 443
            -- >$ ./app --port=443
            , optionLongFlags :: [String]

            -- | Options may have a default value. This will be parsed as if the
            -- user had entered it on the command line.
            , optionDefault :: a

            -- | An option's description is used with the default implementation
            -- of @--help@. It should be a short string describing what the option
            -- does.
            , optionDescription :: String

            -- | Which group the option is in. See the \"Option groups\" section
            -- for details.
            , optionGroup :: Maybe Group

            -- | TODO docs
            , optionLocation :: Maybe Location
            }

    validateOptionDefs :: [OptionInfo] -> [(String, [OptionInfo])] -> Either String OptionDefinitions
    validateOptionDefs cmdInfos subInfos = runIdentity $ runErrorT $ do
            -- All subcommands have unique names.
            let subcmdNames = map fst subInfos
            if Set.size (Set.fromList subcmdNames) /= length subcmdNames
                    -- TODO: the error should mention which subcommand names are duplicated
                    then throwError "Multiple subcommands exist with the same name."
                    else return ()

            -- Each option defines at least one short or long flag.
            let allOptInfos = cmdInfos ++ concat [infos | (_, infos) <- subInfos]
            case mapEither optValidFlags allOptInfos of
                    Left err -> throwError err
                    Right _ -> return ()

            -- There are no duplicate short or long flags, unless:
            -- The flags are defined in separate subcommands.
            -- The flags have identical OptionInfos (aside from keys)
            cmdDeDupedFlags <- checkNoDuplicateFlags Map.empty cmdInfos
            forM_ subInfos (\subInfo -> checkNoDuplicateFlags cmdDeDupedFlags (snd subInfo))

            return (addHelpFlags (OptionDefinitions cmdInfos subInfos))

    optValidFlags :: OptionInfo -> Either String ()
    optValidFlags info = if null (optionInfoShortFlags info) && null (optionInfoLongFlags info)
            then case optionInfoLocation info of
                    Nothing -> Left ("Option with description " ++ show (optionInfoDescription info) ++ " has no flags.")
                    Just loc -> Left ("Option with description " ++ show (optionInfoDescription info) ++ " at " ++ locationFilename loc ++ ":" ++ show (locationLine loc) ++ " has no flags.")
            -- TODO: All short or long flags have a reasonable name.
            else Right ()

    data DeDupFlag = DeDupShort Char | DeDupLong String
            deriving (Eq, Ord, Show)

    checkNoDuplicateFlags :: Map.Map DeDupFlag OptionInfo -> [OptionInfo] -> ErrorT String Identity (Map.Map DeDupFlag OptionInfo)
    checkNoDuplicateFlags checked [] = return checked
    checkNoDuplicateFlags checked (info:infos) = do
            let mappedShort = map DeDupShort (optionInfoShortFlags info)
            let mappedLong = map DeDupLong (optionInfoLongFlags info)
            let mappedFlags = mappedShort ++ mappedLong
            forM_ mappedFlags $ \mapKey -> case Map.lookup mapKey checked of
                    Nothing -> return ()
                    Just prevInfo -> if eqIgnoringKey info prevInfo
                            then return ()
                            else let
                                    flagName = case mapKey of
                                            DeDupShort flag -> '-' : flag : []
                                            DeDupLong long -> "--" ++ long
                                    in throwError ("Duplicate option flag " ++ show flagName ++ ".")

            let infoMap = Map.fromList [(f, info) | f <- mappedFlags]
            checkNoDuplicateFlags (Map.union checked infoMap) infos

    eqIgnoringKey :: OptionInfo -> OptionInfo -> Bool
    eqIgnoringKey x y = normKey x == normKey y where
            normKey info = info { optionInfoKey = OptionKeyIgnored }

    -- | See @'parseOptions'@ and @'parseSubcommand'@.
    class Parsed a where
            parsedError_ :: a -> Maybe String
            parsedHelp_ :: a -> String

    -- | See @'parseOptions'@.
    data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String]

    -- | See @'parseSubcommand'@.
    data ParsedSubcommand action = ParsedSubcommand (Maybe action) (Maybe String) String

    instance Parsed (ParsedOptions a) where
            parsedError_ (ParsedOptions _ x _ _) = x
            parsedHelp_ (ParsedOptions _ _ x _) = x

    instance Parsed (ParsedSubcommand a) where
            parsedError_ (ParsedSubcommand _ x _) = x
            parsedHelp_ (ParsedSubcommand _ _ x) = x

    -- | Get the options value that was parsed from argv, or @Nothing@ if the
    -- arguments could not be converted into options.
    --
    -- Note: This function return @Nothing@ if the user provided a help flag. To
    -- check whether an error occured during parsing, check the value of
    -- @'parsedError'@.
    parsedOptions :: ParsedOptions opts -> Maybe opts
    parsedOptions (ParsedOptions x _ _ _) = x

    -- | Get command-line arguments remaining after parsing options. The arguments
    -- are unchanged from the original argument list, and have not been decoded
    -- or otherwise transformed.
    parsedArguments :: ParsedOptions opts -> [String]
    parsedArguments (ParsedOptions _ _ _ x) = x

    -- | Get the subcommand action that was parsed from argv, or @Nothing@ if the
    -- arguments could not be converted into a valid action.
    --
    -- Note: This function return @Nothing@ if the user provided a help flag. To
    -- check whether an error occured during parsing, check the value of
    -- @'parsedError'@.
    parsedSubcommand :: ParsedSubcommand action -> Maybe action
    parsedSubcommand (ParsedSubcommand x _ _) = x

    -- | Get the error that prevented options from being parsed from argv,
    -- or @Nothing@ if no error was detected.
    parsedError :: Parsed a => a -> Maybe String
    parsedError = parsedError_

    -- | Get a help message to show the user. If the arguments included
    -- a help flag, this will be a message appropriate to that flag.
    -- Otherwise, it is a summary (equivalent to @--help@).
    --
    -- This is always a non-empty string, regardless of whether the parse
    -- succeeded or failed. If you need to perform additional validation
    -- on the options value, this message can be displayed if validation
    -- fails.
    parsedHelp :: Parsed a => a -> String
    parsedHelp = parsedHelp_

    -- | Attempt to convert a list of command-line arguments into an options
    -- value. This can be used by application developers who want finer control
    -- over error handling, or who want to perform additional validation on the
    -- options value.
    --
    -- The argument list must be in the same encoding as the result of
    -- 'System.Environment.getArgs'.
    --
    -- Use @'parsedOptions'@, @'parsedArguments'@, @'parsedError'@, and
    -- @'parsedHelp'@ to inspect the result of @'parseOptions'@.
    --
    -- Example:
    --
    -- @
    --getOptionsOrDie :: Options a => IO a
    --getOptionsOrDie = do
    --    argv <- System.Environment.getArgs
    --    let parsed = 'parseOptions' argv
    --    case 'parsedOptions' parsed of
    --        Just opts -> return opts
    --        Nothing -> case 'parsedError' parsed of
    --            Just err -> do
    --                hPutStrLn stderr ('parsedHelp' parsed)
    --                hPutStrLn stderr err
    --                exitFailure
    --            Nothing -> do
    --                hPutStr stdout ('parsedHelp' parsed)
    --                exitSuccess
    -- @
    parseOptions :: Options opts => [String] -> ParsedOptions opts
    parseOptions argv = parsed where
            (DefineOptions _ getInfos parser) = defineOptions
            (_, optionInfos) = getInfos 0
            parseTokens = parser 0

            parsed = case validateOptionDefs optionInfos [] of
                    Left err -> ParsedOptions Nothing (Just err) "" []
                    Right optionDefs -> case tokenize (addHelpFlags optionDefs) argv of
                            (_, Left err) -> ParsedOptions Nothing (Just err) (helpFor HelpSummary optionDefs Nothing) []
                            (_, Right tokens) -> case checkHelpFlag tokens of
                                    Just helpFlag -> ParsedOptions Nothing Nothing (helpFor helpFlag optionDefs Nothing) []
                                    Nothing -> case parseTokens (tokensMap tokens) of
                                            Left err -> ParsedOptions Nothing (Just err) (helpFor HelpSummary optionDefs Nothing) []
                                            Right (_, opts) -> ParsedOptions (Just opts) Nothing (helpFor HelpSummary optionDefs Nothing) (tokensArgv tokens)

    -- | Retrieve 'System.Environment.getArgs', and attempt to parse it into a
    -- valid value of an 'Options' type plus a list of left-over arguments. The
    -- options and arguments are then passed to the provided computation.
    --
    -- If parsing fails, this computation will print an error and call
    -- 'exitFailure'.
    --
    -- If parsing succeeds, and the user has passed a @--help@ flag, and the
    -- developer is using the default help flag definitions, then this computation
    -- will print documentation and call 'exitSuccess'.
    --
    -- See 'runSubcommand' for details on subcommand support.
    runCommand :: (MonadIO m, Options opts) => (opts -> [String] -> m a) -> m a
    runCommand io = do
            argv <- liftIO System.Environment.getArgs
            let parsed = parseOptions argv
            case parsedOptions parsed of
                    Just opts -> io opts (parsedArguments parsed)
                    Nothing -> liftIO $ case parsedError parsed of
                            Just err -> do
                                    hPutStrLn stderr (parsedHelp parsed)
                                    hPutStrLn stderr err
                                    exitFailure
                            Nothing -> do
                                    hPutStr stdout (parsedHelp parsed)
                                    exitSuccess

    data Subcommand cmdOpts action = Subcommand String (Integer -> ([OptionInfo], (cmdOpts -> Tokens -> Either String action), Integer))

    subcommand :: (Options cmdOpts, Options subcmdOpts)
               => String -- ^ The subcommand name.
               -> (cmdOpts -> subcmdOpts -> [String] -> action) -- ^ The action to run.
               -> Subcommand cmdOpts action
    subcommand name fn = Subcommand name (\initialKey -> let
            (DefineOptions _ getInfos parser) = defineOptions
            (nextKey, optionInfos) = getInfos initialKey
            parseTokens = parser initialKey

            runAction cmdOpts tokens = case parseTokens (tokensMap tokens) of
                    Left err -> Left err
                    Right (_, subOpts) -> Right (fn cmdOpts subOpts (tokensArgv tokens))
            in (optionInfos, runAction, nextKey))

    -- | Attempt to convert a list of command-line arguments into a subcommand
    -- action. This can be used by application developers who want finer control
    -- over error handling, or who want subcommands that run in an unusual monad.
    --
    -- The argument list must be in the same encoding as the result of
    -- 'System.Environment.getArgs'.
    --
    -- Use @'parsedSubcommand'@, @'parsedError'@, and @'parsedHelp'@ to inspect the
    -- result of @'parseSubcommand'@.
    --
    -- Example:
    --
    -- @
    --runSubcommand :: Options cmdOpts => [Subcommand cmdOpts (IO a)] -> IO a
    --runSubcommand subcommands = do
    --    argv <- System.Environment.getArgs
    --    let parsed = 'parseSubcommand' subcommands argv
    --    case 'parsedSubcommand' parsed of
    --        Just cmd -> cmd
    --        Nothing -> case 'parsedError' parsed of
    --            Just err -> do
    --                hPutStrLn stderr ('parsedHelp' parsed)
    --                hPutStrLn stderr err
    --                exitFailure
    --            Nothing -> do
    --                hPutStr stdout ('parsedHelp' parsed)
    --                exitSuccess
    -- @
    --
    parseSubcommand :: Options cmdOpts => [Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
    parseSubcommand subcommands argv = parsed where
            (DefineOptions _ getInfos parser) = defineOptions
            (cmdNextKey, cmdInfos) = getInfos 0
            cmdParseTokens = parser 0

            subcmdInfos = do
                    Subcommand name fn <- subcommands
                    let (infos, _, _) = fn cmdNextKey
                    return (name, infos)

            subcmdRunners = Map.fromList $ do
                    Subcommand name fn <- subcommands
                    let (_, runner, _) = fn cmdNextKey
                    return (name, runner)

            parsed = case validateOptionDefs cmdInfos subcmdInfos of
                    Left err -> ParsedSubcommand Nothing (Just err) ""
                    Right optionDefs -> case tokenize (addHelpFlags optionDefs) argv of
                            (subcmd, Left err) -> ParsedSubcommand Nothing (Just err) (helpFor HelpSummary optionDefs subcmd)
                            (subcmd, Right tokens) -> case checkHelpFlag tokens of
                                    Just helpFlag -> ParsedSubcommand Nothing Nothing (helpFor helpFlag optionDefs subcmd)
                                    Nothing -> case findAction tokens subcmd of
                                            Left err -> ParsedSubcommand Nothing (Just err) (helpFor HelpSummary optionDefs subcmd)
                                            Right action -> ParsedSubcommand (Just action) Nothing (helpFor HelpSummary optionDefs subcmd)

            findAction _ Nothing = Left "No subcommand specified"
            findAction tokens (Just subcmdName) = case cmdParseTokens (tokensMap tokens) of
                    Left err -> Left err
                    Right (_, cmdOpts) -> case Map.lookup subcmdName subcmdRunners of
                            Nothing -> Left ("Unknown subcommand " ++ show subcmdName ++ ".")
                            Just getRunner -> case getRunner cmdOpts tokens of
                                    Left err -> Left err
                                    Right action -> Right action

    -- | Used to run applications that are split into subcommands.
    --
    -- Use 'subcommand' to define available commands and their actions, then pass
    -- them to this computation to select one and run it. If the user specifies
    -- an invalid subcommand, this computation will print an error and call
    -- 'exitFailure'. In handling of invalid flags or @--help@, 'runSubcommand'
    -- acts like 'runCommand'.
    --
    -- @
    --import Control.Applicative
    --import Control.Monad (unless)
    --import Options
    --
    --data MainOptions = MainOptions { optQuiet :: Bool }
    --instance 'Options' MainOptions where
    --    'defineOptions' = pure MainOptions
    --        \<*\> 'simpleOption' \"quiet\" False \"Whether to be quiet.\"
    --
    --data HelloOpts = HelloOpts { optHello :: String }
    --instance 'Options' HelloOpts where
    --    'defineOptions' = pure HelloOpts
    --        \<*\> 'simpleOption' \"hello\" \"Hello!\" \"How to say hello.\"
    --
    --data ByeOpts = ByeOpts { optName :: String }
    --instance 'Options' ByeOpts where
    --    'defineOptions' = pure ByeOpts
    --        \<*\> 'simpleOption' \"name\" \"\" \"The user's name.\"
    --
    --hello :: MainOptions -> HelloOpts -> [String] -> IO ()
    --hello mainOpts opts args = unless (optQuiet mainOpts) $ do
    --    putStrLn (optHello opts)
    --
    --bye :: MainOptions -> ByeOpts -> [String] -> IO ()
    --bye mainOpts opts args = unless (optQuiet mainOpts) $ do
    --    putStrLn (\"Good bye \" ++ optName opts)
    --
    --main :: IO ()
    --main = 'runSubcommand'
    --    [ 'subcommand' \"hello\" hello
    --    , 'subcommand' \"bye\" bye
    --    ]
    -- @
    --
    -- >$ ./app hello
    -- >Hello!
    -- >$ ./app hello --hello='Allo!'
    -- >Allo!
    -- >$ ./app bye
    -- >Good bye
    -- >$ ./app bye --name='Alice'
    -- >Good bye Alice
    runSubcommand :: (Options opts, MonadIO m) => [Subcommand opts (m a)] -> m a
    runSubcommand subcommands = do
            argv <- liftIO System.Environment.getArgs
            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