diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cbits/hoehrmann_utf8.c b/cbits/hoehrmann_utf8.c deleted file mode 100644 --- a/cbits/hoehrmann_utf8.c +++ /dev/null @@ -1,60 +0,0 @@ -/** - * Copyright (c) 2008-2010 Björn Höhrmann - * - * 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; -} diff --git a/cbits/utf8.c b/cbits/utf8.c deleted file mode 100644 --- a/cbits/utf8.c +++ /dev/null @@ -1,102 +0,0 @@ -#include -#include "hoehrmann_utf8.c" - -#include - -/* 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; -} diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,57 @@ +## 1.2.1.2 + +The test framework is changed from `chell` to `hspec`. +This avoids a cyclic dependency between the `options` and `chell` packages. + +Various documentation adjustments. Notably, some of the larger parts of the +documentation are moved from the API documentation to a `readme.md` file. + +The package is now tested with GHC versions 9.2, 9.4, and 9.6. + +Requires an upgrade of the dependency `monads-tf` from `0.1` to `0.3`. + +Published by: Chris Martin + +Date: 2023-07-11 + +## 1.2.1.1 + +Published by: John Millikin + +Date: 2015-01-13 + +## 1.2.1 + +Published by: John Millikin + +Date: 2014-12-14 + +## 1.2 + +Published by: John Millikin + +Date: 2014-05-17 + +## 1.1 + +Published by: John Millikin + +Date: 2014-05-17 + +## 1.0 + +Published by: John Millikin + +Date: 2014-03-02 + +## 0.1.1 + +Published by: John Millikin + +Date: 2012-04-08 + +## 0.1 + +Published by: John Millikin + +Date: 2012-03-24 diff --git a/internal/Options/Help.hs b/internal/Options/Help.hs new file mode 100644 --- /dev/null +++ b/internal/Options/Help.hs @@ -0,0 +1,281 @@ +-- | +-- Module: Options.Help +-- License: MIT +module Options.Help + ( addHelpFlags, + checkHelpFlag, + helpFor, + HelpFlag (..), + ) +where + +import Control.Monad.Writer +import Data.Char (isSpace) +import Data.List (intercalate, partition) +import qualified Data.Map as Map +import Data.Maybe (isNothing, listToMaybe) +import qualified Data.Set as Set +import Options.Tokenize +import Options.Types + +data HelpFlag = HelpSummary | HelpAll | HelpGroup String + deriving (Eq, Show) + +addHelpFlags :: OptionDefinitions -> OptionDefinitions +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 = + Group + { groupName = "all", + groupTitle = "Help Options", + groupDescription = "Show all help options." + } + + optSummary = + OptionInfo + { optionInfoKey = OptionKeyHelpSummary, + optionInfoShortFlags = [], + optionInfoLongFlags = [], + optionInfoDefault = "", + optionInfoUnary = True, + optionInfoUnaryOnly = True, + optionInfoDescription = "Show option summary.", + optionInfoGroup = Just groupHelp, + optionInfoLocation = Nothing, + optionInfoTypeName = "" + } + + optGroupHelp group flag = + OptionInfo + { optionInfoKey = OptionKeyHelpGroup (groupName group), + optionInfoShortFlags = [], + optionInfoLongFlags = [flag], + optionInfoDefault = "", + optionInfoUnary = True, + optionInfoUnaryOnly = True, + optionInfoDescription = groupDescription group, + optionInfoGroup = Just groupHelp, + optionInfoLocation = Nothing, + optionInfoTypeName = "" + } + + 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, _) = uniqueGroups opts + let groups = [g | (g, _) <- groupsAndOpts] + group <- (groupHelp : groups) + let flag = "help-" ++ groupName 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, _) = uniqueGroups subcmdOpts + let groups = [g | (g, _) <- groupsAndOpts] + let newOpts = do + group <- groups + let flag = "help-" ++ groupName group + if Set.member flag (Set.union longFlags subcmdLongFlags) + then [] + else [optGroupHelp group flag] + return (subcmdName, newOpts ++ subcmdOpts) + +checkHelpFlag :: Tokens -> Maybe HelpFlag +checkHelpFlag tokens = flag + where + flag = listToMaybe helpKeys + helpKeys = do + (k, _) <- tokensList tokens + case k of + [OptionKeyHelpSummary] -> return HelpSummary + [OptionKeyHelpGroup "all"] -> return HelpAll + [OptionKeyHelpGroup name] -> return (HelpGroup name) + _ -> [] + +helpFor :: HelpFlag -> OptionDefinitions -> Maybe String -> String +helpFor flag defs subcmd = case flag of + HelpSummary -> execWriter (showHelpSummary defs subcmd) + HelpAll -> execWriter (showHelpAll defs subcmd) + HelpGroup name -> execWriter (showHelpOneGroup defs name 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 + unless (null (optionInfoTypeName info)) do + tell " :: " + tell (optionInfoTypeName info) + tell "\n" + unless (null (optionInfoDescription info)) do + forM_ (wrapWords 76 (optionInfoDescription info)) \line -> do + tell " " + tell line + tell "\n" + unless (null (optionInfoDefault info)) do + tell " default: " + tell (optionInfoDefault info) + tell "\n" + +-- A simple greedy word-wrapper for fixed-width terminals, permitting overruns +-- and ragged edges. +wrapWords :: Int -> String -> [String] +wrapWords breakWidth = wrap + where + wrap line = + if length line <= breakWidth + then [line] + else + if any isBreak line + then case splitAt breakWidth line of + (beforeBreak, afterBreak) -> case reverseBreak isBreak beforeBreak of + (beforeWrap, afterWrap) -> beforeWrap : wrap (afterWrap ++ afterBreak) + else [line] + isBreak c = case c of + '\xA0' -> False -- NO-BREAK SPACE + '\x202F' -> False -- NARROW NO-BREAK SPACE + '\x2011' -> False -- NON-BREAKING HYPHEN + '-' -> True + _ -> isSpace c + reverseBreak :: (a -> Bool) -> [a] -> ([a], [a]) + reverseBreak f xs = case break f (reverse xs) of + (after, before) -> (reverse before, reverse after) + +showHelpSummary :: OptionDefinitions -> Maybe String -> Writer String () +showHelpSummary (OptionDefinitions mainOpts subcmds) subcmd = do + let subcmdOptions = do + subcmdName <- subcmd + opts <- lookup subcmdName subcmds + return (subcmdName, opts) + + let (groupInfos, ungroupedMainOptions) = uniqueGroups mainOpts + + -- Always print --help group + let hasHelp = filter (\(g, _) -> groupName g == "all") groupInfos + forM_ hasHelp showHelpGroup + + unless (null ungroupedMainOptions) do + 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 -> 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) = uniqueGroups mainOpts + + -- Always print --help group first, if present + let (hasHelp, noHelp) = partition (\(g, _) -> groupName 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 :: (Group, [OptionInfo]) -> Writer String () +showHelpGroup (groupInfo, opts) = do + tell (groupTitle groupInfo ++ ":\n") + forM_ opts showOptionHelp + tell "\n" + +showHelpOneGroup :: OptionDefinitions -> String -> Maybe String -> Writer String () +showHelpOneGroup (OptionDefinitions mainOpts subcmds) name subcmd = do + let opts = case subcmd of + Nothing -> mainOpts + Just n -> case lookup n subcmds of + Just infos -> mainOpts ++ infos -- both + Nothing -> mainOpts + let (groupInfos, _) = uniqueGroups opts + + -- Always print --help group + let group = filter (\(g, _) -> groupName g == name) groupInfos + forM_ group showHelpGroup + +uniqueGroups :: [OptionInfo] -> ([(Group, [OptionInfo])], [OptionInfo]) +uniqueGroups allOptions = (Map.elems infoMap, ungroupedOptions) + where + infoMap = Map.fromListWith merge do + opt <- allOptions + case optionInfoGroup opt of + Nothing -> [] + Just g -> [(groupName g, (g, [opt]))] + merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1) + ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)] diff --git a/internal/Options/Tokenize.hs b/internal/Options/Tokenize.hs new file mode 100644 --- /dev/null +++ b/internal/Options/Tokenize.hs @@ -0,0 +1,198 @@ +-- | +-- Module: Options.Tokenize +-- License: MIT +module Options.Tokenize + ( Token (..), + tokenFlagName, + Tokens (..), + tokensMap, + tokenize, + ) +where + +import Control.Monad.Except hiding (throwError) +import qualified Control.Monad.Except +import Control.Monad.State +import Data.Functor.Identity +import qualified Data.Map +import Options.Types +import Options.Util + +data Token + = TokenUnary String -- flag name + | Token String String -- flag name, flag value + deriving (Eq, Show) + +tokenFlagName :: Token -> String +tokenFlagName (TokenUnary s) = s +tokenFlagName (Token s _) = s + +data Tokens = Tokens + { tokensList :: [([OptionKey], Token)], + tokensArgv :: [String] + } + deriving (Show) + +tokensMap :: Tokens -> Data.Map.Map OptionKey [Token] +tokensMap tokens = Data.Map.fromListWith (\xs ys -> ys ++ xs) do + (keys, token) <- tokensList tokens + key <- keys + return (key, [token]) + +data TokState = TokState + { stArgv :: [String], + stArgs :: [String], + stOpts :: [([OptionKey], Token)], + stShortKeys :: Data.Map.Map Char ([OptionKey], OptionInfo), + stLongKeys :: Data.Map.Map String ([OptionKey], OptionInfo), + stSubcommands :: [(String, [OptionInfo])], + stSubCmd :: Maybe String + } + +newtype Tok a = Tok {unTok :: ExceptT String (StateT TokState Identity) a} + +instance Functor Tok where + fmap = liftM + +instance Applicative Tok where + pure = Tok . pure + (<*>) = ap + +instance Monad Tok where + m >>= f = Tok (unTok m >>= unTok . f) + +instance MonadState Tok where + type StateType Tok = TokState + get = Tok get + put = Tok . put + +tokenize :: OptionDefinitions -> [String] -> (Maybe String, Either String Tokens) +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 (runExceptT (unTok loop)) st + return + ( stSubCmd st', + case err of + Left err' -> Left err' + Right _ -> Right (Tokens (reverse (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 :: [OptionKey] -> Token -> Tok () +addOpt keys val = + modify + ( \st -> + st + { stOpts = (keys, val) : stOpts st + } + ) + +mergeSubcommand :: String -> [OptionInfo] -> Tok () +mergeSubcommand name opts = modify \st -> + st + { stSubCmd = Just name, + stShortKeys = Data.Map.unionWith unionKeys (stShortKeys st) (toShortKeys opts), + stLongKeys = Data.Map.unionWith unionKeys (stLongKeys st) (toLongKeys opts) + } + +-- note: unionKeys assumes that the OptionInfo is equivalent in both maps. +unionKeys :: ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) +unionKeys (keys1, info) (keys2, _) = (keys1 ++ keys2, info) + +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 (keys, info) -> + if optionInfoUnaryOnly info + then throwError ("Flag --" ++ before ++ " takes no parameters.") + else addOpt keys (Token ("--" ++ before) value) + _ -> case Data.Map.lookup optName longKeys of + Nothing -> throwError ("Unknown flag --" ++ optName) + Just (keys, info) -> + if optionInfoUnary info + then addOpt keys (TokenUnary ("--" ++ optName)) + else do + next <- nextItem + case next of + Nothing -> throwError ("The flag --" ++ optName ++ " requires a parameter.") + Just value -> addOpt keys (Token ("--" ++ optName) 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 (keys, info) -> + if optionInfoUnary info + then -- don't check optionInfoUnaryOnly, because that's only set by --help + -- options and they define no short flags. + do + addOpt keys (TokenUnary optName) + 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 a parameter.") + Just value -> addOpt keys (Token optName value) + _ -> addOpt keys (Token optName optValue) + +toShortKeys :: [OptionInfo] -> Data.Map.Map Char ([OptionKey], OptionInfo) +toShortKeys opts = Data.Map.fromListWith (\(keys1, info) (keys2, _) -> (keys2 ++ keys1, info)) do + opt <- opts + flag <- optionInfoShortFlags opt + return (flag, ([optionInfoKey opt], opt)) + +toLongKeys :: [OptionInfo] -> Data.Map.Map String ([OptionKey], OptionInfo) +toLongKeys opts = Data.Map.fromListWith (\(keys1, info) (keys2, _) -> (keys2 ++ keys1, info)) do + opt <- opts + flag <- optionInfoLongFlags opt + return (flag, ([optionInfoKey opt], opt)) + +throwError :: String -> Tok a +throwError = Tok . Control.Monad.Except.throwError diff --git a/internal/Options/Types.hs b/internal/Options/Types.hs new file mode 100644 --- /dev/null +++ b/internal/Options/Types.hs @@ -0,0 +1,54 @@ +-- | +-- Module: Options.Types +-- License: MIT +module Options.Types + ( OptionDefinitions (..), + Group (..), + OptionKey (..), + Location (..), + OptionInfo (..), + ) +where + +data OptionDefinitions = OptionDefinitions [OptionInfo] [(String, [OptionInfo])] + +data Group = Group + { groupName :: String, + -- | A short title for the group, which is used when printing + -- @--help@ output. + groupTitle :: String, + -- | A description of the group, which is used when printing + -- @--help@ output. + groupDescription :: String + } + deriving (Eq, Show) + +data OptionKey + = OptionKey String + | OptionKeyHelpSummary + | OptionKeyHelpGroup String + | OptionKeyGenerated Integer + | OptionKeyIgnored + deriving (Eq, Ord, Show) + +data Location = Location + { locationPackage :: String, + locationModule :: String, + locationFilename :: String, + locationLine :: Integer + } + deriving (Eq, Show) + +data OptionInfo = OptionInfo + { optionInfoKey :: OptionKey, + optionInfoShortFlags :: [Char], + optionInfoLongFlags :: [String], + optionInfoDefault :: String, + optionInfoUnary :: Bool, + optionInfoUnaryOnly :: Bool, -- used only for --help and friends + optionInfoDescription :: String, + optionInfoGroup :: Maybe Group, + optionInfoLocation :: Maybe Location, + optionInfoTypeName :: String + } + deriving (Eq, Show) diff --git a/internal/Options/Util.hs b/internal/Options/Util.hs new file mode 100644 --- /dev/null +++ b/internal/Options/Util.hs @@ -0,0 +1,42 @@ +-- | +-- Module: Options.Util +-- License: MIT +module Options.Util where + +import Data.Char (isAlphaNum, isLetter, isUpper) +import qualified Data.Set as Set + +stringToGhc704 :: String -> String +stringToGhc704 = id + +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 + +mapEither :: (a -> Either err b) -> [a] -> Either err [b] +mapEither fn = loop [] + where + loop acc [] = Right (reverse acc) + loop acc (a : as) = case fn a of + Left err -> Left err + Right b -> loop (b : acc) as diff --git a/lib/Options.hs b/lib/Options.hs --- a/lib/Options.hs +++ b/lib/Options.hs @@ -1,1043 +1,925 @@ -{-# 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 +-- | +-- Module: Options +-- License: MIT +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.Monad (forM_) +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Functor.Identity +import Data.Int +import Data.List (intercalate) +import Data.Map qualified as Map +import Data.Maybe (isJust) +import Data.Set qualified as Set +import Data.Word +import Options.Help +import Options.Tokenize +import Options.Types +import Options.Util (mapEither) +import System.Environment qualified +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, hPutStrLn, stderr, stdout) + +-- | 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 :: + -- | Name + String -> + -- | Title; see 'groupTitle'. + String -> + -- | Description; see 'groupDescription'. + String -> + Group +group = Group + +-- | Define a new option type with the given name, default, and behavior +optionType :: + -- | Name + String -> + -- | Default value + val -> + -- | Parser + (String -> Either String val) -> + -- | Formatter + (val -> String) -> + 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. +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. +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 => + -- | Element separator + Char -> + -- | Element type + OptionType a -> + 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 each other. +-- 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 => + -- | Item separator + Char -> + -- | Key/Value separator + Char -> + -- | Key type + OptionType k -> + -- | Value type + OptionType v -> + 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 :: + -- | Element separator + Char -> + -- | Element type + OptionType a -> + 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 +-- +-- This is a simplistic implementation, useful for quick scripts. +-- For more possibilities, see 'optionType'. +optionType_enum :: + (Bounded a, Enum a, Show a) => + -- | Option type name + String -> + 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, + optionLocation :: Maybe Location + } + +validateOptionDefs :: [OptionInfo] -> [(String, [OptionInfo])] -> Either String OptionDefinitions +validateOptionDefs cmdInfos subInfos = runIdentity $ runExceptT do + -- All subcommands have unique names. + let subcmdNames = map fst subInfos + if Set.size (Set.fromList subcmdNames) /= length subcmdNames + then -- TODO: the error should mention which subcommand names are duplicated + 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.") + else -- TODO: All short or long flags have a reasonable name. + Right () + +data DeDupFlag = DeDupShort Char | DeDupLong String + deriving (Eq, Ord, Show) + +checkNoDuplicateFlags :: Map.Map DeDupFlag OptionInfo -> [OptionInfo] -> ExceptT 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 occurred 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 occurred 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 +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) + +-- | Either calls the given continuation, prints help text and calls 'exitSuccess', +-- or prints an error and calls 'exitFailure'. +-- +-- 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) => + -- | The subcommand name + String -> + -- | The action to run + (cmdOpts -> subcmdOpts -> [String] -> action) -> + 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 +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 +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 diff --git a/lib/Options/Help.hs b/lib/Options/Help.hs deleted file mode 100644 --- a/lib/Options/Help.hs +++ /dev/null @@ -1,263 +0,0 @@ --- | --- Module: Options.Help --- License: MIT -module Options.Help - ( addHelpFlags - , checkHelpFlag - , helpFor - , HelpFlag(..) - ) where - -import Control.Monad.Writer -import Data.Char (isSpace) -import Data.List (intercalate, partition) -import Data.Maybe (isNothing, listToMaybe) -import qualified Data.Set as Set -import qualified Data.Map as Map - -import Options.Tokenize -import Options.Types - -data HelpFlag = HelpSummary | HelpAll | HelpGroup String - deriving (Eq, Show) - -addHelpFlags :: OptionDefinitions -> OptionDefinitions -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 = Group - { groupName = "all" - , groupTitle = "Help Options" - , groupDescription = "Show all help options." - } - - optSummary = OptionInfo - { optionInfoKey = OptionKeyHelpSummary - , optionInfoShortFlags = [] - , optionInfoLongFlags = [] - , optionInfoDefault = "" - , optionInfoUnary = True - , optionInfoUnaryOnly = True - , optionInfoDescription = "Show option summary." - , optionInfoGroup = Just groupHelp - , optionInfoLocation = Nothing - , optionInfoTypeName = "" - } - - optGroupHelp group flag = OptionInfo - { optionInfoKey = OptionKeyHelpGroup (groupName group) - , optionInfoShortFlags = [] - , optionInfoLongFlags = [flag] - , optionInfoDefault = "" - , optionInfoUnary = True - , optionInfoUnaryOnly = True - , optionInfoDescription = groupDescription group - , optionInfoGroup = Just groupHelp - , optionInfoLocation = Nothing - , optionInfoTypeName = "" - } - - 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, _) = uniqueGroups opts - let groups = [g | (g, _) <- groupsAndOpts] - group <- (groupHelp : groups) - let flag = "help-" ++ groupName 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, _) = uniqueGroups subcmdOpts - let groups = [g | (g, _) <- groupsAndOpts] - let newOpts = do - group <- groups - let flag = "help-" ++ groupName group - if Set.member flag (Set.union longFlags subcmdLongFlags) - then [] - else [optGroupHelp group flag] - return (subcmdName, newOpts ++ subcmdOpts) - -checkHelpFlag :: Tokens -> Maybe HelpFlag -checkHelpFlag tokens = flag where - flag = listToMaybe helpKeys - helpKeys = do - (k, _) <- tokensList tokens - case k of - [OptionKeyHelpSummary] -> return HelpSummary - [OptionKeyHelpGroup "all"] -> return HelpAll - [OptionKeyHelpGroup name] -> return (HelpGroup name) - _ -> [] - -helpFor :: HelpFlag -> OptionDefinitions -> Maybe String -> String -helpFor flag defs subcmd = case flag of - HelpSummary -> execWriter (showHelpSummary defs subcmd) - HelpAll -> execWriter (showHelpAll defs subcmd) - HelpGroup name -> execWriter (showHelpOneGroup defs name 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 - unless (null (optionInfoTypeName info)) $ do - tell " :: " - tell (optionInfoTypeName info) - tell "\n" - unless (null (optionInfoDescription info)) $ do - forM_ (wrapWords 76 (optionInfoDescription info)) $ \line -> do - tell " " - tell line - tell "\n" - unless (null (optionInfoDefault info)) $ do - tell " default: " - tell (optionInfoDefault info) - tell "\n" - --- A simple greedy word-wrapper for fixed-width terminals, permitting overruns --- and ragged edges. -wrapWords :: Int -> String -> [String] -wrapWords breakWidth = wrap where - wrap line = if length line <= breakWidth - then [line] - else if any isBreak line - then case splitAt breakWidth line of - (beforeBreak, afterBreak) -> case reverseBreak isBreak beforeBreak of - (beforeWrap, afterWrap) -> beforeWrap : wrap (afterWrap ++ afterBreak) - else [line] - isBreak c = case c of - '\xA0' -> False -- NO-BREAK SPACE - '\x202F' -> False -- NARROW NO-BREAK SPACE - '\x2011' -> False -- NON-BREAKING HYPHEN - '-' -> True - _ -> isSpace c - reverseBreak :: (a -> Bool) -> [a] -> ([a], [a]) - reverseBreak f xs = case break f (reverse xs) of - (after, before) -> (reverse before, reverse after) - -showHelpSummary :: OptionDefinitions -> Maybe String -> Writer String () -showHelpSummary (OptionDefinitions mainOpts subcmds) subcmd = do - let subcmdOptions = do - subcmdName <- subcmd - opts <- lookup subcmdName subcmds - return (subcmdName, opts) - - let (groupInfos, ungroupedMainOptions) = uniqueGroups mainOpts - - -- Always print --help group - let hasHelp = filter (\(g,_) -> groupName g == "all") groupInfos - forM_ hasHelp showHelpGroup - - unless (null ungroupedMainOptions) $ do - 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 -> 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) = uniqueGroups mainOpts - - -- Always print --help group first, if present - let (hasHelp, noHelp) = partition (\(g,_) -> groupName 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 :: (Group, [OptionInfo]) -> Writer String () -showHelpGroup (groupInfo, opts) = do - tell (groupTitle groupInfo ++ ":\n") - forM_ opts showOptionHelp - tell "\n" - -showHelpOneGroup :: OptionDefinitions -> String -> Maybe String -> Writer String () -showHelpOneGroup (OptionDefinitions mainOpts subcmds) name subcmd = do - let opts = case subcmd of - Nothing -> mainOpts - Just n -> case lookup n subcmds of - Just infos -> mainOpts ++ infos -- both - Nothing -> mainOpts - let (groupInfos, _) = uniqueGroups opts - - -- Always print --help group - let group = filter (\(g,_) -> groupName g == name) groupInfos - forM_ group showHelpGroup - -uniqueGroups :: [OptionInfo] -> ([(Group, [OptionInfo])], [OptionInfo]) -uniqueGroups allOptions = (Map.elems infoMap, ungroupedOptions) where - infoMap = Map.fromListWith merge $ do - opt <- allOptions - case optionInfoGroup opt of - Nothing -> [] - Just g -> [(groupName g, (g, [opt]))] - merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1) - ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)] diff --git a/lib/Options/Tokenize.hs b/lib/Options/Tokenize.hs deleted file mode 100644 --- a/lib/Options/Tokenize.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - --- | --- Module: Options.Tokenize --- License: MIT -module Options.Tokenize - ( Token(..) - , tokenFlagName - , Tokens(..) - , tokensMap - , tokenize - ) where - -import Control.Applicative -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 Token - = TokenUnary String -- flag name - | Token String String -- flag name, flag value - deriving (Eq, Show) - -tokenFlagName :: Token -> String -tokenFlagName (TokenUnary s) = s -tokenFlagName (Token s _) = s - -data Tokens = Tokens - { tokensList :: [([OptionKey], Token)] - , tokensArgv :: [String] - } - deriving (Show) - -tokensMap :: Tokens -> Data.Map.Map OptionKey [Token] -tokensMap tokens = Data.Map.fromListWith (\xs ys -> ys ++ xs) $ do - (keys, token) <- tokensList tokens - key <- keys - return (key, [token]) - -data TokState = TokState - { stArgv :: [String] - , stArgs :: [String] - , stOpts :: [([OptionKey], Token)] - , stShortKeys :: Data.Map.Map Char ([OptionKey], OptionInfo) - , stLongKeys :: Data.Map.Map String ([OptionKey], OptionInfo) - , stSubcommands :: [(String, [OptionInfo])] - , stSubCmd :: Maybe String - } - -newtype Tok a = Tok { unTok :: ErrorT String (StateT TokState Identity) a } - -instance Functor Tok where - fmap = liftM - -instance Applicative Tok where - pure = return - (<*>) = ap - -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 -> [String] -> (Maybe String, Either String Tokens) -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 (Tokens (reverse (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 :: [OptionKey] -> Token -> Tok () -addOpt keys val = modify (\st -> st - { stOpts = (keys, val) : stOpts st - }) - -mergeSubcommand :: String -> [OptionInfo] -> Tok () -mergeSubcommand name opts = modify $ \st -> st - { stSubCmd = Just name - , stShortKeys = Data.Map.unionWith unionKeys (stShortKeys st) (toShortKeys opts) - , stLongKeys = Data.Map.unionWith unionKeys (stLongKeys st) (toLongKeys opts) - } - --- note: unionKeys assumes that the OptionInfo is equivalent in both maps. -unionKeys :: ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) -unionKeys (keys1, info) (keys2,_) = (keys1++keys2, info) - -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 (keys, info) -> if optionInfoUnaryOnly info - then throwError ("Flag --" ++ before ++ " takes no parameters.") - else addOpt keys (Token ("--" ++ before) value) - _ -> case Data.Map.lookup optName longKeys of - Nothing -> throwError ("Unknown flag --" ++ optName) - Just (keys, info) -> if optionInfoUnary info - then addOpt keys (TokenUnary ("--" ++ optName)) - else do - next <- nextItem - case next of - Nothing -> throwError ("The flag --" ++ optName ++ " requires a parameter.") - Just value -> addOpt keys (Token ("--" ++ optName) 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 (keys, info) -> if optionInfoUnary info - -- don't check optionInfoUnaryOnly, because that's only set by --help - -- options and they define no short flags. - then do - addOpt keys (TokenUnary optName) - 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 a parameter.") - Just value -> addOpt keys (Token optName value) - _ -> addOpt keys (Token optName optValue) - -toShortKeys :: [OptionInfo] -> Data.Map.Map Char ([OptionKey], OptionInfo) -toShortKeys opts = Data.Map.fromListWith (\(keys1, info) (keys2, _) -> (keys2 ++ keys1, info)) $ do - opt <- opts - flag <- optionInfoShortFlags opt - return (flag, ([optionInfoKey opt], opt)) - -toLongKeys :: [OptionInfo] -> Data.Map.Map String ([OptionKey], OptionInfo) -toLongKeys opts = Data.Map.fromListWith (\(keys1, info) (keys2, _) -> (keys2 ++ keys1, info)) $ do - opt <- opts - flag <- optionInfoLongFlags opt - return (flag, ([optionInfoKey opt], opt)) - -throwError :: String -> Tok a -throwError = Tok . Control.Monad.Error.throwError diff --git a/lib/Options/Types.hs b/lib/Options/Types.hs deleted file mode 100644 --- a/lib/Options/Types.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | --- Module: Options.Types --- License: MIT -module Options.Types - ( OptionDefinitions(..) - , Group(..) - , OptionKey(..) - , Location(..) - , OptionInfo(..) - ) where - -data OptionDefinitions = OptionDefinitions [OptionInfo] [(String, [OptionInfo])] - -data Group = Group - { - groupName :: String - - -- | A short title for the group, which is used when printing - -- @--help@ output. - , groupTitle :: String - - -- | A description of the group, which is used when printing - -- @--help@ output. - , groupDescription :: String - } - deriving (Eq, Show) - -data OptionKey - = OptionKey String - | OptionKeyHelpSummary - | OptionKeyHelpGroup String - | OptionKeyGenerated Integer - | OptionKeyIgnored - deriving (Eq, Ord, Show) - -data Location = Location - { locationPackage :: String - , locationModule :: String - , locationFilename :: String - , locationLine :: Integer - } - deriving (Eq, Show) - -data OptionInfo = OptionInfo - { optionInfoKey :: OptionKey - , optionInfoShortFlags :: [Char] - , optionInfoLongFlags :: [String] - , optionInfoDefault :: String - , optionInfoUnary :: Bool - , optionInfoUnaryOnly :: Bool -- used only for --help and friends - , optionInfoDescription :: String - , optionInfoGroup :: Maybe Group - , optionInfoLocation :: Maybe Location - , optionInfoTypeName :: String - } - deriving (Eq, Show) diff --git a/lib/Options/Util.hs b/lib/Options/Util.hs deleted file mode 100644 --- a/lib/Options/Util.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 - -mapEither :: (a -> Either err b) -> [a] -> Either err [b] -mapEither fn = loop [] where - loop acc [] = Right (reverse acc) - loop acc (a:as) = case fn a of - Left err -> Left err - Right b -> loop (b:acc) as diff --git a/options.cabal b/options.cabal --- a/options.cabal +++ b/options.cabal @@ -1,140 +1,69 @@ +cabal-version: 3.0 + name: options -version: 1.2.1.1 +version: 1.2.1.2 +synopsis: Powerful and easy command-line option parser + +description: + Lets library and application developers easily work with command-line options. + license: MIT license-file: license.txt + author: John Millikin -maintainer: John Millikin -build-type: Simple -cabal-version: >= 1.8 +maintainer: Chris Martin + category: Console stability: stable -homepage: https://john-millikin.com/software/haskell-options/ -synopsis: A powerful and easy-to-use command-line option parser. -description: - The @options@ package lets library and application developers easily work - with command-line options. - . - 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 - - -extra-source-files: - cbits/hoehrmann_utf8.c - cbits/utf8.c +homepage: https://github.com/typeclasses/options/ -source-repository head - type: git - location: https://john-millikin.com/code/haskell-options/ +extra-source-files: *.md -source-repository this - type: git - location: https://john-millikin.com/code/haskell-options/ - tag: haskell-options_1.2.1.1 +common base + default-language: GHC2021 + ghc-options: -Wall + default-extensions: BlockArguments TypeFamilies + build-depends: + , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 + , containers ^>= 0.6 + , monads-tf ^>= 0.3 library - ghc-options: -Wall -O2 - cc-options: -Wall - hs-source-dirs: lib - - if !os(windows) && impl(ghc < 7.2) - cpp-options: -DOPTIONS_ENCODING_UTF8 - c-sources: cbits/utf8.c - build-depends: - bytestring >= 0.9 - - if impl(ghc > 7.4) - ghc-options: -fwarn-unsafe - - build-depends: - base >= 4.1 && < 5.0 - , containers >= 0.1 - , monads-tf >= 0.1 - , transformers >= 0.2 + import: base + hs-source-dirs: lib + exposed-modules: Options + build-depends: options-internal +library options-internal + import: base + hs-source-dirs: internal exposed-modules: - Options - - other-modules: - Options.Help - Options.Tokenize - Options.Types - Options.Util + Options.Help + Options.Tokenize + Options.Types + Options.Util test-suite options_tests + import: base type: exitcode-stdio-1.0 - main-is: OptionsTests.hs - - ghc-options: -Wall -O2 - cc-options: -Wall - hs-source-dirs: lib,tests - - if !os(windows) && impl(ghc < 7.2) - cpp-options: -DOPTIONS_ENCODING_UTF8 - c-sources: cbits/utf8.c - build-depends: - bytestring >= 0.9 + main-is: Main.hs + hs-source-dirs: tests + ghc-options: -fno-warn-incomplete-uni-patterns + default-extensions: OverloadedStrings build-depends: - base >= 4.0 && < 5.0 - , chell >= 0.4 && < 0.5 - , chell-quickcheck >= 0.2 && < 0.3 - , containers >= 0.1 - , monads-tf >= 0.1 - , transformers >= 0.2 + , hspec ^>= 2.9.7 || ^>= 2.10 || ^>= 2.11 + , options + , options-internal + , patience ^>= 0.3 other-modules: - OptionsTests.Api - OptionsTests.Help - OptionsTests.OptionTypes - OptionsTests.StringParsing - OptionsTests.Tokenize - OptionsTests.Util + OptionsTests.Api + OptionsTests.Help + OptionsTests.OptionTypes + OptionsTests.StringParsing + OptionsTests.Tokenize + OptionsTests.Util + + Chell diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,262 @@ +The `options` package lets library and application developers easily +work with command-line options. + +This document discusses a handful of the utilities in this package. +See the API documentation for the `Options` module for more. + +## Introductory example + +The following example is a full program that can accept two options, +`--message` and `--quiet`: + +```haskell +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 -> + 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 +``` + +## Defining options + +### optionType_bool + +`optionType_bool` stores 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_enum + +`optionType_enum` 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`. + +Example: + +```haskell +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 +``` + +## Parsing argument lists + +### parseOptions + +`parseOptions` attempts 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: + +```haskell +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 +``` + +### parseSubcommand + +`parseSubcommand` attempts 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: + +```haskell +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 +``` + +## Running main with options + +### runCommand + +`runCommand` retrieves `System.Environment.getArgs` and attempts 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`. + +### runSubcommand + +`runSubcommand` is 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`. + +Example: + +```haskell +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 +``` diff --git a/tests/Chell.hs b/tests/Chell.hs new file mode 100644 --- /dev/null +++ b/tests/Chell.hs @@ -0,0 +1,58 @@ +-- Excerpts copied out of the `chell` package and slightly modified +-- for use with `hspec`. +module Chell where + +import Control.Monad (unless) +import Data.List (foldl', intercalate) +import Data.Maybe (isNothing) +import Patience qualified +import Test.Hspec (Expectation, expectationFailure) + +assertBool :: Bool -> String -> Expectation +assertBool b s = unless b $ expectationFailure s + +-- | Assert that some value is @Nothing@. +nothing :: Show a => Maybe a -> Expectation +nothing x = + assertBool + (isNothing x) + ("nothing: received " ++ showsPrec 11 x "") + +-- | Assert that some value is @Right@. +right :: Show a => Either a b -> Expectation +right (Right _) = pure () +right (Left a) = expectationFailure ("right: received " ++ showsPrec 11 dummy "") + where + dummy = Left a `asTypeOf` Right () + +-- | Assert that some value is @Left@. +left :: Show b => Either a b -> Expectation +left (Left _) = pure () +left (Right b) = expectationFailure ("left: received " ++ showsPrec 11 dummy "") + where + dummy = Right b `asTypeOf` Left () + +-- | Assert that two pieces of text are equal. This uses a diff algorithm +-- to check line-by-line, so the error message will be easier to read on +-- large inputs. +equalLines :: String -> String -> Expectation +equalLines x y = checkLinesDiff "equalLines" (lines x) (lines y) + +checkLinesDiff :: String -> [String] -> [String] -> Expectation +checkLinesDiff label = go + where + go xs ys = + case checkItems (Patience.diff xs ys) of + (same, diff) -> assertBool same diff + + checkItems diffItems = + case foldl' checkItem (True, []) diffItems of + (same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff))) + + checkItem (same, acc) item = + case item of + Patience.Old t -> (False, ("\t- " ++ t) : acc) + Patience.New t -> (False, ("\t+ " ++ t) : acc) + Patience.Both t _ -> (same, ("\t " ++ t) : acc) + + errorMsg diff = label ++ ": lines differ\n" ++ diff diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,21 @@ +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module Main (main) where + +import OptionsTests.Api (suite_Api) +import OptionsTests.Help (suite_Help) +import OptionsTests.OptionTypes (suite_OptionTypes) +import OptionsTests.StringParsing (suite_StringParsing) +import OptionsTests.Tokenize (suite_Tokenize) +import OptionsTests.Util (suite_Util) +import Test.Hspec (hspec) + +main :: IO () +main = hspec do + suite_Api + suite_Help + suite_OptionTypes + suite_StringParsing + suite_Tokenize + suite_Util diff --git a/tests/OptionsTests.hs b/tests/OptionsTests.hs deleted file mode 100644 --- a/tests/OptionsTests.hs +++ /dev/null @@ -1,29 +0,0 @@ --- Copyright (C) 2012 John Millikin --- --- See license.txt for details -module Main - ( tests - , main - ) where - -import Test.Chell (Suite, defaultMain) - -import OptionsTests.Api (suite_Api) -import OptionsTests.Help (suite_Help) -import OptionsTests.OptionTypes (suite_OptionTypes) -import OptionsTests.StringParsing (suite_StringParsing) -import OptionsTests.Tokenize (suite_Tokenize) -import OptionsTests.Util (suite_Util) - -tests :: [Suite] -tests = - [ suite_Api - , suite_Help - , suite_OptionTypes - , suite_StringParsing - , suite_Tokenize - , suite_Util - ] - -main :: IO () -main = Test.Chell.defaultMain tests diff --git a/tests/OptionsTests/Api.hs b/tests/OptionsTests/Api.hs --- a/tests/OptionsTests/Api.hs +++ b/tests/OptionsTests/Api.hs @@ -1,83 +1,86 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2014 John Millikin -- -- See license.txt for details -module OptionsTests.Api - ( suite_Api - ) where - -import Control.Applicative -import Test.Chell +module OptionsTests.Api (suite_Api) where -import Options +import Chell (nothing) +import Options +import Test.Hspec (Spec, context, shouldBe, specify) -suite_Api :: Suite -suite_Api = suite "api" - [ test_RepeatedFlags - , test_CompatibleDuplicateFlags - , test_ConflictingDuplicateFlags - ] +suite_Api :: Spec +suite_Api = context "api" do + test_RepeatedFlags + test_CompatibleDuplicateFlags + test_ConflictingDuplicateFlags data RepeatedStringOpts = RepeatedStringOpts [String] - deriving (Eq, Show) + deriving (Eq, Show) repeatedStringList :: OptionType [String] -repeatedStringList = (optionType "repeated-string-list" [] (\x -> Right [x]) show) - { optionTypeMerge = Just concat - } +repeatedStringList = + (optionType "repeated-string-list" [] (\x -> Right [x]) show) + { optionTypeMerge = Just concat + } instance Options RepeatedStringOpts where - defineOptions = pure RepeatedStringOpts - <*> defineOption repeatedStringList (\o -> o - { optionShortFlags = ['s'] - }) + defineOptions = + pure RepeatedStringOpts + <*> defineOption + repeatedStringList + ( \o -> + o + { optionShortFlags = ['s'] + } + ) -test_RepeatedFlags :: Test -test_RepeatedFlags = assertions "repeated-flags" $ do - let parsed = parseOptions ["-sfoo", "-sbar", "-sbaz"] - $expect (nothing (parsedError parsed)) - $expect (equal (parsedOptions parsed) (Just (RepeatedStringOpts ["foo", "bar", "baz"]))) +test_RepeatedFlags :: Spec +test_RepeatedFlags = specify "repeated-flags" do + let parsed = parseOptions ["-sfoo", "-sbar", "-sbaz"] + nothing (parsedError parsed) + shouldBe (parsedOptions parsed) (Just (RepeatedStringOpts ["foo", "bar", "baz"])) data CompatibleDuplicateOpts = CompatibleDuplicateOpts SubOpts1 SubOpts1 - deriving (Eq, Show) + deriving (Eq, Show) instance Options CompatibleDuplicateOpts where - defineOptions = pure CompatibleDuplicateOpts - <*> defineOptions - <*> defineOptions + defineOptions = + pure CompatibleDuplicateOpts + <*> defineOptions + <*> defineOptions data ConflictingDuplicateOpts = ConflictingDuplicateOpts SubOpts1 SubOpts2 - deriving (Eq, Show) + deriving (Eq, Show) instance Options ConflictingDuplicateOpts where - defineOptions = pure ConflictingDuplicateOpts - <*> defineOptions - <*> defineOptions + defineOptions = + pure ConflictingDuplicateOpts + <*> defineOptions + <*> defineOptions data SubOpts1 = SubOpts1 Integer - deriving (Eq, Show) + deriving (Eq, Show) data SubOpts2 = SubOpts2 Integer - deriving (Eq, Show) + deriving (Eq, Show) instance Options SubOpts1 where - defineOptions = pure SubOpts1 - <*> simpleOption "int" 0 "" + defineOptions = + pure SubOpts1 + <*> simpleOption "int" 0 "" instance Options SubOpts2 where - defineOptions = pure SubOpts2 - <*> simpleOption "int" 1 "" + defineOptions = + pure SubOpts2 + <*> simpleOption "int" 1 "" -test_CompatibleDuplicateFlags :: Test -test_CompatibleDuplicateFlags = assertions "compatible-duplicate-flags" $ do - let parsed = parseOptions ["--int=10"] - $expect (nothing (parsedError parsed)) - $expect (equal (parsedOptions parsed) (Just (CompatibleDuplicateOpts (SubOpts1 10) (SubOpts1 10)))) +test_CompatibleDuplicateFlags :: Spec +test_CompatibleDuplicateFlags = specify "compatible-duplicate-flags" do + let parsed = parseOptions ["--int=10"] + nothing (parsedError parsed) + shouldBe (parsedOptions parsed) (Just (CompatibleDuplicateOpts (SubOpts1 10) (SubOpts1 10))) -test_ConflictingDuplicateFlags :: Test -test_ConflictingDuplicateFlags = assertions "conflicting-duplicate-flags" $ do - let parsed = parseOptions ["-sfoo", "-sbar", "-sbaz"] - $expect (equal (parsedError parsed) (Just "Duplicate option flag \"--int\".")) - $expect (nothing (parsedOptions parsed :: Maybe ConflictingDuplicateOpts)) +test_ConflictingDuplicateFlags :: Spec +test_ConflictingDuplicateFlags = specify "conflicting-duplicate-flags" do + let parsed = parseOptions ["-sfoo", "-sbar", "-sbaz"] + shouldBe (parsedError parsed) (Just "Duplicate option flag \"--int\".") + nothing (parsedOptions parsed :: Maybe ConflictingDuplicateOpts) diff --git a/tests/OptionsTests/Help.hs b/tests/OptionsTests/Help.hs --- a/tests/OptionsTests/Help.hs +++ b/tests/OptionsTests/Help.hs @@ -1,399 +1,473 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2012 John Millikin -- -- See license.txt for details -module OptionsTests.Help - ( suite_Help - ) where - -import Test.Chell +module OptionsTests.Help (suite_Help) where -import Options.Help -import Options.Tokenize -import Options.Types +import Chell (equalLines) +import Options.Help +import Options.Tokenize (Token (TokenUnary), Tokens (Tokens)) +import Options.Types +import Test.Hspec (Spec, context, shouldBe, specify) -suite_Help :: Suite -suite_Help = suite "help" $ - suiteTests suite_AddHelpFlags ++ - [ test_CheckHelpFlag - , test_ShowHelpSummary - , test_ShowHelpSummary_Subcommand - , test_ShowHelpAll - , test_ShowHelpAll_Subcommand - , test_ShowHelpGroup - , test_ShowHelpGroup_Subcommand - , test_ShowHelpGroup_SubcommandInvalid - ] +suite_Help :: Spec +suite_Help = context "help" do + suite_AddHelpFlags + test_CheckHelpFlag + test_ShowHelpSummary + test_ShowHelpSummary_Subcommand + test_ShowHelpAll + test_ShowHelpAll_Subcommand + test_ShowHelpGroup + test_ShowHelpGroup_Subcommand + test_ShowHelpGroup_SubcommandInvalid -suite_AddHelpFlags :: Suite -suite_AddHelpFlags = suite "addHelpFlags" - [ test_AddHelpFlags_None - , test_AddHelpFlags_Short - , test_AddHelpFlags_Long - , test_AddHelpFlags_Both - , test_AddHelpFlags_NoAll - , test_AddHelpFlags_Subcommand - ] +suite_AddHelpFlags :: Spec +suite_AddHelpFlags = context "addHelpFlags" do + test_AddHelpFlags_None + test_AddHelpFlags_Short + test_AddHelpFlags_Long + test_AddHelpFlags_Both + test_AddHelpFlags_NoAll + test_AddHelpFlags_Subcommand groupHelp :: Maybe Group -groupHelp = Just (Group - { groupName = "all" - , groupTitle = "Help Options" - , groupDescription = "Show all help options." - }) +groupHelp = + Just + ( Group + { groupName = "all", + groupTitle = "Help Options", + groupDescription = "Show all help options." + } + ) infoHelpSummary :: [Char] -> [String] -> OptionInfo -infoHelpSummary shorts longs = OptionInfo - { optionInfoKey = OptionKeyHelpSummary - , optionInfoShortFlags = shorts - , optionInfoLongFlags = longs - , optionInfoDefault = "" - , optionInfoUnary = True - , optionInfoUnaryOnly = True - , optionInfoDescription = "Show option summary." - , optionInfoGroup = groupHelp - , optionInfoLocation = Nothing - , optionInfoTypeName = "" - } +infoHelpSummary shorts longs = + OptionInfo + { optionInfoKey = OptionKeyHelpSummary, + optionInfoShortFlags = shorts, + optionInfoLongFlags = longs, + optionInfoDefault = "", + optionInfoUnary = True, + optionInfoUnaryOnly = True, + optionInfoDescription = "Show option summary.", + optionInfoGroup = groupHelp, + optionInfoLocation = Nothing, + optionInfoTypeName = "" + } infoHelpAll :: OptionInfo -infoHelpAll = OptionInfo - { optionInfoKey = OptionKeyHelpGroup "all" - , optionInfoShortFlags = [] - , optionInfoLongFlags = ["help-all"] - , optionInfoDefault = "" - , optionInfoUnary = True - , optionInfoUnaryOnly = True - , optionInfoDescription = "Show all help options." - , optionInfoGroup = groupHelp - , optionInfoLocation = Nothing - , optionInfoTypeName = "" - } +infoHelpAll = + OptionInfo + { optionInfoKey = OptionKeyHelpGroup "all", + optionInfoShortFlags = [], + optionInfoLongFlags = ["help-all"], + optionInfoDefault = "", + optionInfoUnary = True, + optionInfoUnaryOnly = True, + optionInfoDescription = "Show all help options.", + optionInfoGroup = groupHelp, + optionInfoLocation = Nothing, + optionInfoTypeName = "" + } -test_AddHelpFlags_None :: Test -test_AddHelpFlags_None = assertions "none" $ do - let commandDefs = OptionDefinitions - [ OptionInfo (OptionKey "test.help") ['h'] ["help"] "default" False False "" Nothing Nothing "" - ] - [] - let helpAdded = addHelpFlags commandDefs - let OptionDefinitions opts subcmds = helpAdded - - $expect (equal opts - [ infoHelpAll - , OptionInfo (OptionKey "test.help") ['h'] ["help"] "default" False False "" Nothing Nothing "" - ]) - $expect (equal subcmds []) +test_AddHelpFlags_None :: Spec +test_AddHelpFlags_None = specify "none" $ do + let commandDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.help") ['h'] ["help"] "default" False False "" Nothing Nothing "" + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded -test_AddHelpFlags_Short :: Test -test_AddHelpFlags_Short = assertions "short" $ do - let commandDefs = OptionDefinitions - [ OptionInfo (OptionKey "test.help") [] ["help"] "default" False False "" Nothing Nothing "" - ] - [] - let helpAdded = addHelpFlags commandDefs - let OptionDefinitions opts subcmds = helpAdded - - $expect (equal opts - [ infoHelpSummary ['h'] [] - , infoHelpAll - , OptionInfo (OptionKey "test.help") [] ["help"] "default" False False "" Nothing Nothing "" - ]) - $expect (equal subcmds []) + shouldBe + opts + [ infoHelpAll, + OptionInfo (OptionKey "test.help") ['h'] ["help"] "default" False False "" Nothing Nothing "" + ] + shouldBe subcmds [] -test_AddHelpFlags_Long :: Test -test_AddHelpFlags_Long = assertions "long" $ do - let commandDefs = OptionDefinitions - [ OptionInfo (OptionKey "test.help") ['h'] [] "default" False False "" Nothing Nothing "" - ] - [] - let helpAdded = addHelpFlags commandDefs - let OptionDefinitions opts subcmds = helpAdded - - $expect (equal opts - [ infoHelpSummary [] ["help"] - , infoHelpAll - , OptionInfo (OptionKey "test.help") ['h'] [] "default" False False "" Nothing Nothing "" - ]) - $expect (equal subcmds []) +test_AddHelpFlags_Short :: Spec +test_AddHelpFlags_Short = specify "short" $ do + let commandDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.help") [] ["help"] "default" False False "" Nothing Nothing "" + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded -test_AddHelpFlags_Both :: Test -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 []) + shouldBe + opts + [ infoHelpSummary ['h'] [], + infoHelpAll, + OptionInfo (OptionKey "test.help") [] ["help"] "default" False False "" Nothing Nothing "" + ] + shouldBe subcmds [] -test_AddHelpFlags_NoAll :: Test -test_AddHelpFlags_NoAll = assertions "no-all" $ do - let commandDefs = OptionDefinitions - [ OptionInfo (OptionKey "test.help") ['h'] ["help", "help-all"] "default" False False "" Nothing Nothing "" - ] - [] - let helpAdded = addHelpFlags commandDefs - let OptionDefinitions opts subcmds = helpAdded - - $expect (equal opts - [ OptionInfo (OptionKey "test.help") ['h'] ["help", "help-all"] "default" False False "" Nothing Nothing "" - ]) - $expect (equal subcmds []) +test_AddHelpFlags_Long :: Spec +test_AddHelpFlags_Long = specify "long" $ do + let commandDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.help") ['h'] [] "default" False False "" Nothing Nothing "" + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded -test_AddHelpFlags_Subcommand :: Test -test_AddHelpFlags_Subcommand = assertions "subcommand" $ do - let cmd1_a = OptionInfo (OptionKey "test.cmd1.a") ['a'] [] "" False False "" (Just Group - { groupName = "foo" - , groupTitle = "Foo Options" - , groupDescription = "More Foo Options" - }) Nothing "" - let cmd1_b = OptionInfo (OptionKey "test.cmd1.b") ['b'] [] "" False False "" (Just Group - { groupName = "all" - , groupTitle = "All Options" - , groupDescription = "More All Options" - }) Nothing "" - let commandDefs = OptionDefinitions - [] - [("cmd1", [cmd1_a, cmd1_b])] - let helpAdded = addHelpFlags commandDefs - let OptionDefinitions opts subcmds = helpAdded - - let helpFoo = OptionInfo - { optionInfoKey = OptionKeyHelpGroup "foo" - , optionInfoShortFlags = [] - , optionInfoLongFlags = ["help-foo"] - , optionInfoDefault = "" - , optionInfoUnary = True - , optionInfoUnaryOnly = True - , optionInfoDescription = "More Foo Options" - , optionInfoGroup = Just (Group - { groupName = "all" - , groupTitle = "Help Options" - , groupDescription = "Show all help options." - }) - , optionInfoLocation = Nothing - , optionInfoTypeName = "" - } - - $expect (equal opts - [ infoHelpSummary ['h'] ["help"] - , infoHelpAll - ]) - $expect (equal subcmds [("cmd1", [helpFoo, cmd1_a, cmd1_b])]) + shouldBe + opts + [ infoHelpSummary [] ["help"], + infoHelpAll, + OptionInfo (OptionKey "test.help") ['h'] [] "default" False False "" Nothing Nothing "" + ] + shouldBe subcmds [] -test_CheckHelpFlag :: Test -test_CheckHelpFlag = assertions "checkHelpFlag" $ do - let checkFlag keys = equal (checkHelpFlag (Tokens [([k], TokenUnary "-h") | k <- keys] [])) - - $expect (checkFlag [] Nothing) - $expect (checkFlag [OptionKeyHelpSummary] (Just HelpSummary)) - $expect (checkFlag [OptionKeyHelpGroup "all"] (Just HelpAll)) - $expect (checkFlag [OptionKeyHelpGroup "foo"] (Just (HelpGroup "foo"))) +test_AddHelpFlags_Both :: Spec +test_AddHelpFlags_Both = specify "both" $ do + let commandDefs = OptionDefinitions [] [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + shouldBe + opts + [ infoHelpSummary ['h'] ["help"], + infoHelpAll + ] + shouldBe subcmds [] + +test_AddHelpFlags_NoAll :: Spec +test_AddHelpFlags_NoAll = specify "no-all" $ do + let commandDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.help") ['h'] ["help", "help-all"] "default" False False "" Nothing Nothing "" + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + shouldBe + opts + [ OptionInfo (OptionKey "test.help") ['h'] ["help", "help-all"] "default" False False "" Nothing Nothing "" + ] + shouldBe subcmds [] + +test_AddHelpFlags_Subcommand :: Spec +test_AddHelpFlags_Subcommand = specify "subcommand" $ do + let cmd1_a = + OptionInfo + (OptionKey "test.cmd1.a") + ['a'] + [] + "" + False + False + "" + ( Just + Group + { groupName = "foo", + groupTitle = "Foo Options", + groupDescription = "More Foo Options" + } + ) + Nothing + "" + let cmd1_b = + OptionInfo + (OptionKey "test.cmd1.b") + ['b'] + [] + "" + False + False + "" + ( Just + Group + { groupName = "all", + groupTitle = "All Options", + groupDescription = "More All Options" + } + ) + Nothing + "" + let commandDefs = + OptionDefinitions + [] + [("cmd1", [cmd1_a, cmd1_b])] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + let helpFoo = + OptionInfo + { optionInfoKey = OptionKeyHelpGroup "foo", + optionInfoShortFlags = [], + optionInfoLongFlags = ["help-foo"], + optionInfoDefault = "", + optionInfoUnary = True, + optionInfoUnaryOnly = True, + optionInfoDescription = "More Foo Options", + optionInfoGroup = + Just + ( Group + { groupName = "all", + groupTitle = "Help Options", + groupDescription = "Show all help options." + } + ), + optionInfoLocation = Nothing, + optionInfoTypeName = "" + } + + shouldBe + opts + [ infoHelpSummary ['h'] ["help"], + infoHelpAll + ] + shouldBe subcmds [("cmd1", [helpFoo, cmd1_a, cmd1_b])] + +test_CheckHelpFlag :: Spec +test_CheckHelpFlag = specify "checkHelpFlag" $ do + let checkFlag keys = shouldBe (checkHelpFlag (Tokens [([k], TokenUnary "-h") | k <- keys] [])) + + checkFlag [] Nothing + checkFlag [OptionKeyHelpSummary] (Just HelpSummary) + checkFlag [OptionKeyHelpGroup "all"] (Just HelpAll) + checkFlag [OptionKeyHelpGroup "foo"] (Just (HelpGroup "foo")) + variedOptions :: OptionDefinitions -variedOptions = addHelpFlags $ OptionDefinitions - [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "def" False False "a description here" Nothing Nothing "" - , OptionInfo (OptionKey "test.long1") [] ["a-looooooooooooong-option"] "def" False False "description here" Nothing Nothing "" - , OptionInfo (OptionKey "test.long2") [] ["a-loooooooooooooong-option"] "def" False False "description here" Nothing Nothing "" - , OptionInfo (OptionKey "test.b") ['b'] ["long-b"] "def" False False "b description here" Nothing Nothing "" - , OptionInfo (OptionKey "test.g") ['g'] ["long-g"] "def" False False "g description here" (Just Group - { groupName = "group" - , groupTitle = "Grouped options" - , groupDescription = "Show grouped options." - }) Nothing "" - ] - [ ("cmd1", - [ OptionInfo (OptionKey "test.cmd1.z") ['z'] ["long-z"] "def" False False "z description here" Nothing Nothing "" - ]) - , ("cmd2", - [ OptionInfo (OptionKey "test.cmd2.y") ['y'] ["long-y"] "def" False False "y description here" Nothing Nothing "" - , OptionInfo (OptionKey "test.cmd2.g2") [] ["long-g2"] "def" False False "g2 description here" (Just Group - { groupName = "group" - , groupTitle = "Grouped options" - , groupDescription = "Show grouped options." - }) Nothing "" - ]) - ] +variedOptions = + addHelpFlags $ + OptionDefinitions + [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "def" False False "a description here" Nothing Nothing "", + OptionInfo (OptionKey "test.long1") [] ["a-looooooooooooong-option"] "def" False False "description here" Nothing Nothing "", + OptionInfo (OptionKey "test.long2") [] ["a-loooooooooooooong-option"] "def" False False "description here" Nothing Nothing "", + OptionInfo (OptionKey "test.b") ['b'] ["long-b"] "def" False False "b description here" Nothing Nothing "", + OptionInfo + (OptionKey "test.g") + ['g'] + ["long-g"] + "def" + False + False + "g description here" + ( Just + Group + { groupName = "group", + groupTitle = "Grouped options", + groupDescription = "Show grouped options." + } + ) + Nothing + "" + ] + [ ( "cmd1", + [ OptionInfo (OptionKey "test.cmd1.z") ['z'] ["long-z"] "def" False False "z description here" Nothing Nothing "" + ] + ), + ( "cmd2", + [ OptionInfo (OptionKey "test.cmd2.y") ['y'] ["long-y"] "def" False False "y description here" Nothing Nothing "", + OptionInfo + (OptionKey "test.cmd2.g2") + [] + ["long-g2"] + "def" + False + False + "g2 description here" + ( Just + Group + { groupName = "group", + groupTitle = "Grouped options", + groupDescription = "Show grouped options." + } + ) + Nothing + "" + ] + ) + ] -test_ShowHelpSummary :: Test -test_ShowHelpSummary = assertions "showHelpSummary" $ do - let expected = "\ - \Help Options:\n\ - \ -h, --help\n\ - \ Show option summary.\n\ - \ --help-all\n\ - \ Show all help options.\n\ - \ --help-group\n\ - \ Show grouped options.\n\ - \\n\ - \Application Options:\n\ - \ -a, --long-a\n\ - \ a description here\n\ - \ default: def\n\ - \ --a-looooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ --a-loooooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ -b, --long-b\n\ - \ b description here\n\ - \ default: def\n\ - \\n\ - \Subcommands:\n\ - \ cmd1\n\ - \ cmd2\n\ - \\n" - $expect (equalLines expected (helpFor HelpSummary variedOptions Nothing)) +test_ShowHelpSummary :: Spec +test_ShowHelpSummary = specify "showHelpSummary" $ do + let expected = + "\ + \Help Options:\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ + \\n\ + \Subcommands:\n\ + \ cmd1\n\ + \ cmd2\n\ + \\n" + equalLines expected (helpFor HelpSummary variedOptions Nothing) -test_ShowHelpSummary_Subcommand :: Test -test_ShowHelpSummary_Subcommand = assertions "showHelpSummary-subcommand" $ do - let expected = "\ - \Help Options:\n\ - \ -h, --help\n\ - \ Show option summary.\n\ - \ --help-all\n\ - \ Show all help options.\n\ - \ --help-group\n\ - \ Show grouped options.\n\ - \\n\ - \Application Options:\n\ - \ -a, --long-a\n\ - \ a description here\n\ - \ default: def\n\ - \ --a-looooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ --a-loooooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ -b, --long-b\n\ - \ b description here\n\ - \ default: def\n\ - \\n\ - \Options for subcommand \"cmd1\":\n\ - \ -z, --long-z\n\ - \ z description here\n\ - \ default: def\n\ - \\n" - $expect (equalLines expected (helpFor HelpSummary variedOptions (Just "cmd1"))) +test_ShowHelpSummary_Subcommand :: Spec +test_ShowHelpSummary_Subcommand = specify "showHelpSummary-subcommand" $ do + let expected = + "\ + \Help Options:\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ + \\n\ + \Options for subcommand \"cmd1\":\n\ + \ -z, --long-z\n\ + \ z description here\n\ + \ default: def\n\ + \\n" + equalLines expected (helpFor HelpSummary variedOptions (Just "cmd1")) -test_ShowHelpAll :: Test -test_ShowHelpAll = assertions "showHelpAll" $ do - let expected = "\ - \Help Options:\n\ - \ -h, --help\n\ - \ Show option summary.\n\ - \ --help-all\n\ - \ Show all help options.\n\ - \ --help-group\n\ - \ Show grouped options.\n\ - \\n\ - \Grouped options:\n\ - \ -g, --long-g\n\ - \ g description here\n\ - \ default: def\n\ - \\n\ - \Application Options:\n\ - \ -a, --long-a\n\ - \ a description here\n\ - \ default: def\n\ - \ --a-looooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ --a-loooooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ -b, --long-b\n\ - \ b description here\n\ - \ default: def\n\ - \\n\ - \Options for subcommand \"cmd1\":\n\ - \ -z, --long-z\n\ - \ z description here\n\ - \ default: def\n\ - \\n\ - \Options for subcommand \"cmd2\":\n\ - \ -y, --long-y\n\ - \ y description here\n\ - \ default: def\n\ - \ --long-g2\n\ - \ g2 description here\n\ - \ default: def\n\ - \\n" - $expect (equalLines expected (helpFor HelpAll variedOptions Nothing)) +test_ShowHelpAll :: Spec +test_ShowHelpAll = specify "showHelpAll" $ do + let expected = + "\ + \Help Options:\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ + \\n\ + \Grouped options:\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ + \\n\ + \Options for subcommand \"cmd1\":\n\ + \ -z, --long-z\n\ + \ z description here\n\ + \ default: def\n\ + \\n\ + \Options for subcommand \"cmd2\":\n\ + \ -y, --long-y\n\ + \ y description here\n\ + \ default: def\n\ + \ --long-g2\n\ + \ g2 description here\n\ + \ default: def\n\ + \\n" + equalLines expected (helpFor HelpAll variedOptions Nothing) -test_ShowHelpAll_Subcommand :: Test -test_ShowHelpAll_Subcommand = assertions "showHelpAll-subcommand" $ do - let expected = "\ - \Help Options:\n\ - \ -h, --help\n\ - \ Show option summary.\n\ - \ --help-all\n\ - \ Show all help options.\n\ - \ --help-group\n\ - \ Show grouped options.\n\ - \\n\ - \Grouped options:\n\ - \ -g, --long-g\n\ - \ g description here\n\ - \ default: def\n\ - \\n\ - \Application Options:\n\ - \ -a, --long-a\n\ - \ a description here\n\ - \ default: def\n\ - \ --a-looooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ --a-loooooooooooooong-option\n\ - \ description here\n\ - \ default: def\n\ - \ -b, --long-b\n\ - \ b description here\n\ - \ default: def\n\ - \\n\ - \Options for subcommand \"cmd1\":\n\ - \ -z, --long-z\n\ - \ z description here\n\ - \ default: def\n\ - \\n" - $expect (equalLines expected (helpFor HelpAll variedOptions (Just "cmd1"))) +test_ShowHelpAll_Subcommand :: Spec +test_ShowHelpAll_Subcommand = specify "showHelpAll-subcommand" $ do + let expected = + "\ + \Help Options:\n\ + \ -h, --help\n\ + \ Show option summary.\n\ + \ --help-all\n\ + \ Show all help options.\n\ + \ --help-group\n\ + \ Show grouped options.\n\ + \\n\ + \Grouped options:\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a\n\ + \ a description here\n\ + \ default: def\n\ + \ --a-looooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ default: def\n\ + \ -b, --long-b\n\ + \ b description here\n\ + \ default: def\n\ + \\n\ + \Options for subcommand \"cmd1\":\n\ + \ -z, --long-z\n\ + \ z description here\n\ + \ default: def\n\ + \\n" + equalLines expected (helpFor HelpAll variedOptions (Just "cmd1")) -test_ShowHelpGroup :: Test -test_ShowHelpGroup = assertions "showHelpGroup" $ do - let expected = "\ - \Grouped options:\n\ - \ -g, --long-g\n\ - \ g description here\n\ - \ default: def\n\ - \\n" - $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions Nothing)) +test_ShowHelpGroup :: Spec +test_ShowHelpGroup = specify "showHelpGroup" $ do + let expected = + "\ + \Grouped options:\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ + \\n" + equalLines expected (helpFor (HelpGroup "group") variedOptions Nothing) -test_ShowHelpGroup_Subcommand :: Test -test_ShowHelpGroup_Subcommand = assertions "showHelpGroup-subcommand" $ do - let expected = "\ - \Grouped options:\n\ - \ -g, --long-g\n\ - \ g description here\n\ - \ default: def\n\ - \ --long-g2\n\ - \ g2 description here\n\ - \ default: def\n\ - \\n" - $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "cmd2"))) +test_ShowHelpGroup_Subcommand :: Spec +test_ShowHelpGroup_Subcommand = specify "showHelpGroup-subcommand" $ do + let expected = + "\ + \Grouped options:\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ + \ --long-g2\n\ + \ g2 description here\n\ + \ default: def\n\ + \\n" + equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "cmd2")) -test_ShowHelpGroup_SubcommandInvalid :: Test -test_ShowHelpGroup_SubcommandInvalid = assertions "showHelpGroup-subcommand-invalid" $ do - let expected = "\ - \Grouped options:\n\ - \ -g, --long-g\n\ - \ g description here\n\ - \ default: def\n\ - \\n" - $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "noexist"))) +test_ShowHelpGroup_SubcommandInvalid :: Spec +test_ShowHelpGroup_SubcommandInvalid = specify "showHelpGroup-subcommand-invalid" $ do + let expected = + "\ + \Grouped options:\n\ + \ -g, --long-g\n\ + \ g description here\n\ + \ default: def\n\ + \\n" + equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "noexist")) diff --git a/tests/OptionsTests/OptionTypes.hs b/tests/OptionsTests/OptionTypes.hs --- a/tests/OptionsTests/OptionTypes.hs +++ b/tests/OptionsTests/OptionTypes.hs @@ -1,317 +1,307 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2012 John Millikin -- -- See license.txt for details -module OptionsTests.OptionTypes - ( suite_OptionTypes - ) where +module OptionsTests.OptionTypes (suite_OptionTypes) where -import Data.Int -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Word +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Word (Word16, Word32, Word64, Word8) +import Options +import Test.Hspec (Expectation, Spec, context, shouldBe, specify) -import Test.Chell +suite_OptionTypes :: Spec +suite_OptionTypes = context "option-types" do + test_Bool + test_String + test_Int + test_Int8 + test_Int16 + test_Int32 + test_Int64 + test_Word + test_Word8 + test_Word16 + test_Word32 + test_Word64 + test_Integer + test_Float + test_Double + test_Maybe + test_List + test_Set + test_Map + test_Enum -import Options +parseValid :: (Show a, Eq a) => OptionType a -> String -> a -> Expectation +parseValid t s expected = shouldBe (optionTypeParse t s) (Right expected) -suite_OptionTypes :: Suite -suite_OptionTypes = suite "option-types" - [ test_Bool - , test_String - , test_Int - , test_Int8 - , test_Int16 - , test_Int32 - , test_Int64 - , test_Word - , test_Word8 - , test_Word16 - , test_Word32 - , test_Word64 - , test_Integer - , test_Float - , test_Double - , test_Maybe - , test_List - , test_Set - , test_Map - , test_Enum - ] +parseInvalid :: (Show a, Eq a) => OptionType a -> String -> String -> Expectation +parseInvalid t s err = shouldBe (optionTypeParse t s) (Left err) -parseValid :: (Show a, Eq a) => OptionType a -> String -> a -> Assertion -parseValid t s expected = equal (optionTypeParse t s) (Right expected) +test_Bool :: Spec +test_Bool = specify "bool" $ do + parseValid optionType_bool "true" True + parseValid optionType_bool "false" False + parseInvalid optionType_bool "" "\"\" is not in {\"true\", \"false\"}." -parseInvalid :: (Show a, Eq a) => OptionType a -> String -> String -> Assertion -parseInvalid t s err = equal (optionTypeParse t s) (Left err) +test_String :: Spec +test_String = specify "string" $ do + let valid = parseValid optionType_string -test_Bool :: Test -test_Bool = assertions "bool" $ do - $expect (parseValid optionType_bool "true" True) - $expect (parseValid optionType_bool "false" False) - $expect (parseInvalid optionType_bool "" "\"\" is not in {\"true\", \"false\"}.") + valid "" "" + valid "a" "a" + valid "\12354" "\12354" + valid "\56507" "\56507" + valid "\61371" "\61371" -test_String :: Test -test_String = assertions "string" $ do - let valid = parseValid optionType_string - let invalid = parseInvalid optionType_string - - $expect (valid "" "") - $expect (valid "a" "a") - $expect (valid "\12354" "\12354") - $expect (valid "\56507" "\56507") - $expect (valid "\61371" "\61371") +test_Int :: Spec +test_Int = specify "int" $ do + let valid = parseValid optionType_int + let invalid = parseInvalid optionType_int -test_Int :: Test -test_Int = assertions "int" $ do - let valid = parseValid optionType_int - let invalid = parseInvalid optionType_int - - $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)) + valid "-1" (-1 :: Int) + valid "1" (1 :: Int) + invalid "a" "\"a\" is not an integer." -test_Int8 :: Test -test_Int8 = assertions "int8" $ do - let valid = parseValid optionType_int8 - let invalid = parseInvalid optionType_int8 - - $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.") + 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." -test_Int16 :: Test -test_Int16 = assertions "int16" $ do - let valid = parseValid optionType_int16 - let invalid = parseInvalid optionType_int16 - - $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.") + invalid pastMin (pastMin ++ errBounds) + valid (show (minBound :: Int)) minBound + valid (show (maxBound :: Int)) maxBound + invalid pastMax (pastMax ++ errBounds) -test_Int32 :: Test -test_Int32 = assertions "int32" $ do - let valid = parseValid optionType_int32 - let invalid = parseInvalid optionType_int32 - - $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_Int8 :: Spec +test_Int8 = specify "int8" $ do + let valid = parseValid optionType_int8 + let invalid = parseInvalid optionType_int8 -test_Int64 :: Test -test_Int64 = assertions "int64" $ do - let valid = parseValid optionType_int64 - let invalid = parseInvalid optionType_int64 - - $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.") + valid "-1" (-1 :: Int8) + valid "1" (1 :: Int8) + invalid "a" "\"a\" is not an integer." -test_Word :: Test -test_Word = assertions "word" $ do - let valid = parseValid optionType_word - let invalid = parseInvalid optionType_word - - let pastMax = show (toInteger (maxBound :: Word) + 1) - let errBounds = " is not within bounds [0:" ++ show (maxBound :: Word) ++ "] of type uint." - - $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)) + let pastMin = show (toInteger (minBound :: Int8) - 1) + let pastMax = show (toInteger (maxBound :: Int8) + 1) + invalid pastMin "-129 is not within bounds [-128:127] of type int8." + valid (show (minBound :: Int8)) minBound + valid (show (maxBound :: Int8)) maxBound + invalid pastMax "128 is not within bounds [-128:127] of type int8." -test_Word8 :: Test -test_Word8 = assertions "word8" $ do - let valid = parseValid optionType_word8 - let invalid = parseInvalid optionType_word8 - - $expect (invalid "-1" "-1 is not within bounds [0:255] of type uint8.") - $expect (valid "0" (0 :: Word8)) - $expect (valid "1" (1 :: Word8)) - $expect (invalid "a" "\"a\" is not an integer.") - - let pastMax = show (toInteger (maxBound :: Word8) + 1) - $expect (valid (show (maxBound :: Word8)) maxBound) - $expect (invalid pastMax "256 is not within bounds [0:255] of type uint8.") +test_Int16 :: Spec +test_Int16 = specify "int16" $ do + let valid = parseValid optionType_int16 + let invalid = parseInvalid optionType_int16 -test_Word16 :: Test -test_Word16 = assertions "word16" $ do - let valid = parseValid optionType_word16 - let invalid = parseInvalid optionType_word16 - - $expect (invalid "-1" "-1 is not within bounds [0:65535] of type uint16.") - $expect (valid "0" (0 :: Word16)) - $expect (valid "1" (1 :: Word16)) - $expect (invalid "a" "\"a\" is not an integer.") - - let pastMax = show (toInteger (maxBound :: Word16) + 1) - $expect (valid (show (maxBound :: Word16)) maxBound) - $expect (invalid pastMax "65536 is not within bounds [0:65535] of type uint16.") + valid "-1" (-1 :: Int16) + valid "1" (1 :: Int16) + invalid "a" "\"a\" is not an integer." -test_Word32 :: Test -test_Word32 = assertions "word32" $ do - let valid = parseValid optionType_word32 - let invalid = parseInvalid optionType_word32 - - $expect (invalid "-1" "-1 is not within bounds [0:4294967295] of type uint32.") - $expect (valid "0" (0 :: Word32)) - $expect (valid "1" (1 :: Word32)) - $expect (invalid "a" "\"a\" is not an integer.") - - let pastMax = show (toInteger (maxBound :: Word32) + 1) - $expect (valid (show (maxBound :: Word32)) maxBound) - $expect (invalid pastMax "4294967296 is not within bounds [0:4294967295] of type uint32.") + let pastMin = show (toInteger (minBound :: Int16) - 1) + let pastMax = show (toInteger (maxBound :: Int16) + 1) + invalid pastMin "-32769 is not within bounds [-32768:32767] of type int16." + valid (show (minBound :: Int16)) minBound + valid (show (maxBound :: Int16)) maxBound + invalid pastMax "32768 is not within bounds [-32768:32767] of type int16." -test_Word64 :: Test -test_Word64 = assertions "word64" $ do - let valid = parseValid optionType_word64 - let invalid = parseInvalid optionType_word64 - - $expect (invalid "-1" "-1 is not within bounds [0:18446744073709551615] of type uint64.") - $expect (valid "0" (0 :: Word64)) - $expect (valid "1" (1 :: Word64)) - $expect (invalid "a" "\"a\" is not an integer.") - - let pastMax = show (toInteger (maxBound :: Word64) + 1) - $expect (valid (show (maxBound :: Word64)) maxBound) - $expect (invalid pastMax "18446744073709551616 is not within bounds [0:18446744073709551615] of type uint64.") +test_Int32 :: Spec +test_Int32 = specify "int32" $ do + let valid = parseValid optionType_int32 + let invalid = parseInvalid optionType_int32 -test_Integer :: Test -test_Integer = assertions "integer" $ do - let valid = parseValid optionType_integer - let invalid = parseInvalid optionType_integer - - $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.") + valid "-1" (-1 :: Int32) + valid "1" (1 :: Int32) + invalid "a" "\"a\" is not an integer." -test_Float :: Test -test_Float = assertions "float" $ do - let valid = parseValid optionType_float - let invalid = parseInvalid optionType_float - - $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.") + let pastMin = show (toInteger (minBound :: Int32) - 1) + let pastMax = show (toInteger (maxBound :: Int32) + 1) + invalid pastMin "-2147483649 is not within bounds [-2147483648:2147483647] of type int32." + valid (show (minBound :: Int32)) minBound + valid (show (maxBound :: Int32)) maxBound + invalid pastMax "2147483648 is not within bounds [-2147483648:2147483647] of type int32." -test_Double :: Test -test_Double = assertions "double" $ do - let valid = parseValid optionType_double - let invalid = parseInvalid optionType_double - - $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_Int64 :: Spec +test_Int64 = specify "int64" $ do + let valid = parseValid optionType_int64 + let invalid = parseInvalid optionType_int64 -test_Maybe :: Test -test_Maybe = assertions "maybe" $ do - let t = optionType_maybe optionType_int - let valid = parseValid t - let invalid = parseInvalid t - - $expect (valid "" Nothing) - $expect (valid "1" (Just 1)) - $expect (invalid "a" "\"a\" is not an integer.") + valid "-1" (-1 :: Int64) + valid "1" (1 :: Int64) + invalid "a" "\"a\" is not an integer." -test_List :: Test -test_List = assertions "list" $ do - let t = optionType_list ',' optionType_int - 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.") + let pastMin = show (toInteger (minBound :: Int64) - 1) + let pastMax = show (toInteger (maxBound :: Int64) + 1) + invalid pastMin "-9223372036854775809 is not within bounds [-9223372036854775808:9223372036854775807] of type int64." + valid (show (minBound :: Int64)) minBound + valid (show (maxBound :: Int64)) maxBound + invalid pastMax "9223372036854775808 is not within bounds [-9223372036854775808:9223372036854775807] of type int64." -test_Set :: Test -test_Set = assertions "set" $ do - let t = optionType_set ',' optionType_int - 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_Word :: Spec +test_Word = specify "word" $ do + let valid = parseValid optionType_word + let invalid = parseInvalid optionType_word -test_Map :: Test -test_Map = assertions "map" $ do - let t = optionType_map ',' '=' optionType_int optionType_int - 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.") + let pastMax = show (toInteger (maxBound :: Word) + 1) + let errBounds = " is not within bounds [0:" ++ show (maxBound :: Word) ++ "] of type uint." + invalid "-1" ("-1" ++ errBounds) + valid "0" (0 :: Word) + valid "1" (1 :: Word) + invalid "a" "\"a\" is not an integer." + + valid (show (maxBound :: Word)) maxBound + invalid pastMax (pastMax ++ errBounds) + +test_Word8 :: Spec +test_Word8 = specify "word8" $ do + let valid = parseValid optionType_word8 + let invalid = parseInvalid optionType_word8 + + invalid "-1" "-1 is not within bounds [0:255] of type uint8." + valid "0" (0 :: Word8) + valid "1" (1 :: Word8) + invalid "a" "\"a\" is not an integer." + + let pastMax = show (toInteger (maxBound :: Word8) + 1) + valid (show (maxBound :: Word8)) maxBound + invalid pastMax "256 is not within bounds [0:255] of type uint8." + +test_Word16 :: Spec +test_Word16 = specify "word16" $ do + let valid = parseValid optionType_word16 + let invalid = parseInvalid optionType_word16 + + invalid "-1" "-1 is not within bounds [0:65535] of type uint16." + valid "0" (0 :: Word16) + valid "1" (1 :: Word16) + invalid "a" "\"a\" is not an integer." + + let pastMax = show (toInteger (maxBound :: Word16) + 1) + valid (show (maxBound :: Word16)) maxBound + invalid pastMax "65536 is not within bounds [0:65535] of type uint16." + +test_Word32 :: Spec +test_Word32 = specify "word32" $ do + let valid = parseValid optionType_word32 + let invalid = parseInvalid optionType_word32 + + invalid "-1" "-1 is not within bounds [0:4294967295] of type uint32." + valid "0" (0 :: Word32) + valid "1" (1 :: Word32) + invalid "a" "\"a\" is not an integer." + + let pastMax = show (toInteger (maxBound :: Word32) + 1) + valid (show (maxBound :: Word32)) maxBound + invalid pastMax "4294967296 is not within bounds [0:4294967295] of type uint32." + +test_Word64 :: Spec +test_Word64 = specify "word64" $ do + let valid = parseValid optionType_word64 + let invalid = parseInvalid optionType_word64 + + invalid "-1" "-1 is not within bounds [0:18446744073709551615] of type uint64." + valid "0" (0 :: Word64) + valid "1" (1 :: Word64) + invalid "a" "\"a\" is not an integer." + + let pastMax = show (toInteger (maxBound :: Word64) + 1) + valid (show (maxBound :: Word64)) maxBound + invalid pastMax "18446744073709551616 is not within bounds [0:18446744073709551615] of type uint64." + +test_Integer :: Spec +test_Integer = specify "integer" $ do + let valid = parseValid optionType_integer + let invalid = parseInvalid optionType_integer + + invalid "" "\"\" is not an integer." + valid "-1" (-1 :: Integer) + valid "0" (0 :: Integer) + valid "1" (1 :: Integer) + invalid "a" "\"a\" is not an integer." + +test_Float :: Spec +test_Float = specify "float" $ do + let valid = parseValid optionType_float + let invalid = parseInvalid optionType_float + + valid "-1" (-1 :: Float) + valid "0" (0 :: Float) + valid "1" (1 :: Float) + valid "1.5" (1.5 :: Float) + valid "3e5" (3e5 :: Float) + invalid "a" "\"a\" is not a number." + +test_Double :: Spec +test_Double = specify "double" $ do + let valid = parseValid optionType_double + let invalid = parseInvalid optionType_double + + valid "-1" (-1 :: Double) + valid "0" (0 :: Double) + valid "1" (1 :: Double) + valid "1.5" (1.5 :: Double) + valid "3e5" (3e5 :: Double) + invalid "a" "\"a\" is not a number." + +test_Maybe :: Spec +test_Maybe = specify "maybe" $ do + let t = optionType_maybe optionType_int + let valid = parseValid t + let invalid = parseInvalid t + + valid "" Nothing + valid "1" (Just 1) + invalid "a" "\"a\" is not an integer." + +test_List :: Spec +test_List = specify "list" $ do + let t = optionType_list ',' optionType_int + let valid = parseValid t + let invalid = parseInvalid t + + valid "" [] + valid "1" [1] + valid "1,2,3" [1, 2, 3] + valid "1,1,2,3" [1, 1, 2, 3] + invalid "1,a,3" "\"a\" is not an integer." + +test_Set :: Spec +test_Set = specify "set" $ do + let t = optionType_set ',' optionType_int + let valid = parseValid t + let invalid = parseInvalid t + + valid "" Set.empty + valid "1" (Set.fromList [1]) + valid "1,2,3" (Set.fromList [1, 2, 3]) + valid "1,1,2,3" (Set.fromList [1, 2, 3]) + invalid "1,a,3" "\"a\" is not an integer." + +test_Map :: Spec +test_Map = specify "map" $ do + let t = optionType_map ',' '=' optionType_int optionType_int + let valid = parseValid t + let invalid = parseInvalid t + + valid "" Map.empty + valid "1=100" (Map.fromList [(1, 100)]) + valid "1=100,2=200,3=300" (Map.fromList [(1, 100), (2, 200), (3, 300)]) + valid "1=100,2=200,1=300" (Map.fromList [(1, 300), (2, 200)]) + invalid "a=1" "\"a\" is not an integer." + invalid "1=a" "\"a\" is not an integer." + invalid "1=" "\"\" is not an integer." + invalid "1" "Map item \"1\" has no value." + data TestEnum = Enum1 | Enum2 | Enum3 - deriving (Bounded, Enum, Eq, Show) + deriving (Bounded, Enum, Eq, Show) -test_Enum :: Test -test_Enum = assertions "enum" $ do - let t = optionType_enum "test enum" - let valid = parseValid t - let invalid = parseInvalid t - - $expect (valid "Enum1" Enum1) - $expect (valid "Enum2" Enum2) - $expect (invalid "Enum4" "\"Enum4\" is not in {\"Enum1\", \"Enum2\", \"Enum3\"}.") +test_Enum :: Spec +test_Enum = specify "enum" $ do + let t = optionType_enum "test enum" + let valid = parseValid t + let invalid = parseInvalid t + + valid "Enum1" Enum1 + valid "Enum2" Enum2 + invalid "Enum4" "\"Enum4\" is not in {\"Enum1\", \"Enum2\", \"Enum3\"}." diff --git a/tests/OptionsTests/StringParsing.hs b/tests/OptionsTests/StringParsing.hs --- a/tests/OptionsTests/StringParsing.hs +++ b/tests/OptionsTests/StringParsing.hs @@ -1,77 +1,59 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2012 John Millikin -- -- See license.txt for details -module OptionsTests.StringParsing - ( suite_StringParsing - ) where - -import Control.Applicative -import Test.Chell +module OptionsTests.StringParsing (suite_StringParsing) where -import Options +import Options +import Test.Hspec data StringOptions = StringOptions - { optString :: String - , optString_defA :: String - , optString_defU :: String - } + { optString :: String, + optString_defA :: String, + optString_defU :: String + } instance Options StringOptions where - defineOptions = pure StringOptions - <*> simpleOption "string" "" "" - -- String, ASCII default - <*> simpleOption "string_defA" "a" "" - -- String, Unicode default - <*> simpleOption "string_defU" "\12354" "" + defineOptions = + pure StringOptions + <*> simpleOption "string" "" "" + -- String, ASCII default + <*> simpleOption "string_defA" "a" "" + -- String, Unicode default + <*> simpleOption "string_defU" "\12354" "" -suite_StringParsing :: Suite -suite_StringParsing = suite "string-parsing" - [ test_Defaults - , test_Ascii - , test_UnicodeValid - , test_UnicodeInvalid - ] +suite_StringParsing :: Spec +suite_StringParsing = context "string-parsing" do + test_Defaults + test_Ascii + test_UnicodeValid + test_UnicodeInvalid -test_Defaults :: Test -test_Defaults = assertions "defaults" $ do - let opts = defaultOptions - - $expect (equal (optString_defA opts) "a") - $expect (equal (optString_defU opts) "\12354") -test_Ascii :: Test -test_Ascii = assertions "ascii" $ do - let parsed = parseOptions ["--string=a"] - let Just opts = parsedOptions parsed - - $expect (equal (optString opts) "a") +test_Defaults :: Spec +test_Defaults = specify "defaults" $ do + let opts = defaultOptions -test_UnicodeValid :: Test -test_UnicodeValid = assertions "unicode-valid" $ do -#if defined(OPTIONS_ENCODING_UTF8) - let parsed = parseOptions ["--string=\227\129\130"] -#else - let parsed = parseOptions ["--string=\12354"] -#endif - let Just opts = parsedOptions parsed - - $expect (equal (optString opts) "\12354") + shouldBe (optString_defA opts) "a" + shouldBe (optString_defU opts) "\12354" -test_UnicodeInvalid :: Test -test_UnicodeInvalid = assertions "unicode-invalid" $ do -#if __GLASGOW_HASKELL__ >= 704 - let parsed = parseOptions ["--string=\56507"] - let expectedString = "\56507" -#elif __GLASGOW_HASKELL__ >= 702 - let parsed = parseOptions ["--string=\61371"] - let expectedString = "\61371" -#else - let parsed = parseOptions ["--string=\187"] - let expectedString = "\56507" -#endif - let Just opts = parsedOptions parsed - - $expect (equal (optString opts) expectedString) +test_Ascii :: Spec +test_Ascii = specify "ascii" $ do + let parsed = parseOptions ["--string=a"] + let Just opts = parsedOptions parsed + + shouldBe (optString opts) "a" + +test_UnicodeValid :: Spec +test_UnicodeValid = specify "unicode-valid" $ do + let parsed = parseOptions ["--string=\12354"] + let Just opts = parsedOptions parsed + + shouldBe (optString opts) "\12354" + +test_UnicodeInvalid :: Spec +test_UnicodeInvalid = specify "unicode-invalid" $ do + let parsed = parseOptions ["--string=\56507"] + let expectedString = "\56507" + let Just opts = parsedOptions parsed + + shouldBe (optString opts) expectedString diff --git a/tests/OptionsTests/Tokenize.hs b/tests/OptionsTests/Tokenize.hs --- a/tests/OptionsTests/Tokenize.hs +++ b/tests/OptionsTests/Tokenize.hs @@ -1,326 +1,319 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2012 John Millikin -- -- See license.txt for details -module OptionsTests.Tokenize - ( suite_Tokenize - ) where - -import Test.Chell +module OptionsTests.Tokenize (suite_Tokenize) where -import Options.Types -import Options.Tokenize +import Chell (left, right) +import Options.Tokenize +import Options.Types +import Test.Hspec (Expectation, Spec, context, shouldBe, specify) -suite_Tokenize :: Suite -suite_Tokenize = suite "tokenize" - [ test_Empty - , test_NoFlag - , test_ShortFlag - , test_ShortFlagUnknown - , test_ShortFlagMissing - , test_ShortFlagUnary - , test_ShortFlagDuplicate - , test_LongFlag - , test_LongFlagUnknown - , test_LongFlagMissing - , test_LongFlagUnary - , test_LongFlagDuplicate - , test_EndFlags - , test_Subcommand - , test_SubcommandUnknown - , test_Unicode - ] +suite_Tokenize :: Spec +suite_Tokenize = context "tokenize" do + 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 (OptionKey "test.a") ['a'] ["long-a"] "default" False False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.x") ['x'] ["long-x"] "default" True False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.y") ['y'] ["long-y"] "default" True False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.z") ['z'] ["long-z"] "default" True False "" Nothing Nothing "" - ] - [] +commandDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "default" False False "" Nothing Nothing "", + OptionInfo (OptionKey "test.x") ['x'] ["long-x"] "default" True False "" Nothing Nothing "", + OptionInfo (OptionKey "test.y") ['y'] ["long-y"] "default" True False "" Nothing Nothing "", + OptionInfo (OptionKey "test.z") ['z'] ["long-z"] "default" True False "" Nothing Nothing "" + ] + [] subcommandDefs :: OptionDefinitions -subcommandDefs = OptionDefinitions - [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "default" False False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.b") ['b'] ["long-b"] "default" False False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.x") ['x'] ["long-x"] "default" True False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.y") ['y'] ["long-y"] "default" True False "" Nothing Nothing "" - , OptionInfo (OptionKey "test.z") ['z'] ["long-z"] "default" True False "" Nothing Nothing "" - ] - [ ("sub1", - [ OptionInfo (OptionKey "sub.d") ['d'] ["long-d"] "default" False False "" Nothing Nothing "" - , OptionInfo (OptionKey "sub.e") ['e'] ["long-e"] "default" True False "" Nothing Nothing "" - ]) - , ("sub2", - [ OptionInfo (OptionKey "sub.d") ['d'] ["long-d"] "default" True False "" Nothing Nothing "" - , OptionInfo (OptionKey "sub.e") ['e'] ["long-e"] "default" True False "" Nothing Nothing "" - ]) - ] +subcommandDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.a") ['a'] ["long-a"] "default" False False "" Nothing Nothing "", + OptionInfo (OptionKey "test.b") ['b'] ["long-b"] "default" False False "" Nothing Nothing "", + OptionInfo (OptionKey "test.x") ['x'] ["long-x"] "default" True False "" Nothing Nothing "", + OptionInfo (OptionKey "test.y") ['y'] ["long-y"] "default" True False "" Nothing Nothing "", + OptionInfo (OptionKey "test.z") ['z'] ["long-z"] "default" True False "" Nothing Nothing "" + ] + [ ( "sub1", + [ OptionInfo (OptionKey "sub.d") ['d'] ["long-d"] "default" False False "" Nothing Nothing "", + OptionInfo (OptionKey "sub.e") ['e'] ["long-e"] "default" True False "" Nothing Nothing "" + ] + ), + ( "sub2", + [ OptionInfo (OptionKey "sub.d") ['d'] ["long-d"] "default" True False "" Nothing Nothing "", + OptionInfo (OptionKey "sub.e") ['e'] ["long-e"] "default" True False "" Nothing Nothing "" + ] + ) + ] unicodeDefs :: OptionDefinitions -unicodeDefs = OptionDefinitions - [ OptionInfo (OptionKey "test.a") ['\12354'] ["long-\12354"] "default" False False "" Nothing Nothing "" - ] - [] +unicodeDefs = + OptionDefinitions + [ OptionInfo (OptionKey "test.a") ['\12354'] ["long-\12354"] "default" False False "" Nothing Nothing "" + ] + [] -test_Empty :: Test -test_Empty = assertions "empty" $ do - let (subcmd, eTokens) = tokenize commandDefs [] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [] tokens) - $expect (equal [] args) +test_Empty :: Spec +test_Empty = specify "empty" do + let (subcmd, eTokens) = tokenize commandDefs [] + shouldBe Nothing subcmd + right eTokens -test_NoFlag :: Test -test_NoFlag = assertions "no-flag" $ do - let (subcmd, eTokens) = tokenize commandDefs ["-", "foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [] tokens) - $expect (equal ["-", "foo", "bar"] args) + let Right (Tokens tokens args) = eTokens + equalTokens [] tokens + shouldBe [] args -test_ShortFlag :: Test -test_ShortFlag = assertions "short-flag" $ do - do - let (subcmd, eTokens) = tokenize commandDefs ["-a", "foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-a" "foo")] tokens) - $expect (equal ["bar"] args) - do - let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-a" "foo")] tokens) - $expect (equal ["bar"] args) +test_NoFlag :: Spec +test_NoFlag = specify "no-flag" do + let (subcmd, eTokens) = tokenize commandDefs ["-", "foo", "bar"] + shouldBe Nothing subcmd + right eTokens -test_ShortFlagUnknown :: Test -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) + let Right (Tokens tokens args) = eTokens + equalTokens [] tokens + shouldBe ["-", "foo", "bar"] args -test_ShortFlagMissing :: Test -test_ShortFlagMissing = assertions "short-flag-missing" $ do - let (subcmd, eTokens) = tokenize commandDefs ["-a"] - $expect (equal Nothing subcmd) - $assert (left eTokens) - - let Left err = eTokens - $expect (equal "The flag -a requires a parameter." err) +test_ShortFlag :: Spec +test_ShortFlag = specify "short-flag" do + do + let (subcmd, eTokens) = tokenize commandDefs ["-a", "foo", "bar"] + shouldBe Nothing subcmd + right eTokens -test_ShortFlagUnary :: Test -test_ShortFlagUnary = assertions "short-flag-unary" $ do - do - let (subcmd, eTokens) = tokenize commandDefs ["-x", "foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "-x")] tokens) - $expect (equal ["foo", "bar"] args) - do - let (subcmd, eTokens) = tokenize commandDefs ["-xy", "foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "-x"), ("test.y", TokenUnary "-y")] tokens) - $expect (equal ["foo", "bar"] args) + let Right (Tokens tokens args) = eTokens + equalTokens [("test.a", Token "-a" "foo")] tokens + shouldBe ["bar"] args + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "bar"] + shouldBe Nothing subcmd + right eTokens -test_ShortFlagDuplicate :: Test -test_ShortFlagDuplicate = assertions "short-flag-duplicate" $ do - do - let (subcmd, eTokens) = tokenize commandDefs ["-x", "-x"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "-x"), ("test.x", TokenUnary "-x")] tokens) - do - let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-a", "foo"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "-a" "foo")] tokens) - do - let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-afoo"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "-a" "foo")] tokens) + let Right (Tokens tokens args) = eTokens + equalTokens [("test.a", Token "-a" "foo")] tokens + shouldBe ["bar"] args -test_LongFlag :: Test -test_LongFlag = assertions "long-flag" $ do - do - let (subcmd, eTokens) = tokenize commandDefs ["--long-a", "foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "--long-a" "foo")] tokens) - $expect (equal ["bar"] args) - do - let (subcmd, eTokens) = tokenize commandDefs ["--long-a=foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "--long-a" "foo")] tokens) - $expect (equal ["bar"] args) +test_ShortFlagUnknown :: Spec +test_ShortFlagUnknown = specify "short-flag-unknown" do + let (subcmd, eTokens) = tokenize commandDefs ["-c", "foo", "bar"] + shouldBe Nothing subcmd + left eTokens -test_LongFlagUnknown :: Test -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) + let Left err = eTokens + shouldBe "Unknown flag -c" err -test_LongFlagMissing :: Test -test_LongFlagMissing = assertions "long-flag-missing" $ do - let (subcmd, eTokens) = tokenize commandDefs ["--long-a"] - $expect (equal Nothing subcmd) - $assert (left eTokens) - - let Left err = eTokens - $expect (equal "The flag --long-a requires a parameter." err) +test_ShortFlagMissing :: Spec +test_ShortFlagMissing = specify "short-flag-missing" do + let (subcmd, eTokens) = tokenize commandDefs ["-a"] + shouldBe Nothing subcmd + left eTokens -test_LongFlagUnary :: Test -test_LongFlagUnary = assertions "long-flag-unary" $ do - do - let (subcmd, eTokens) = tokenize commandDefs ["--long-x", "foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "--long-x")] tokens) - $expect (equal ["foo", "bar"] args) - do - let (subcmd, eTokens) = tokenize commandDefs ["--long-x=foo", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", Token "--long-x" "foo")] tokens) - $expect (equal ["bar"] args) + let Left err = eTokens + shouldBe "The flag -a requires a parameter." err -test_LongFlagDuplicate :: Test -test_LongFlagDuplicate = assertions "long-flag-duplicate" $ do - do - let (subcmd, eTokens) = tokenize commandDefs ["-x", "--long-x"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "-x"), ("test.x", TokenUnary "--long-x")] tokens) - do - let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a", "foo"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "--long-a" "foo")] tokens) - do - let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a=foo"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "--long-a" "foo")] tokens) +test_ShortFlagUnary :: Spec +test_ShortFlagUnary = specify "short-flag-unary" do + do + let (subcmd, eTokens) = tokenize commandDefs ["-x", "foo", "bar"] + shouldBe Nothing subcmd + right eTokens -test_EndFlags :: Test -test_EndFlags = assertions "end-flags" $ do - let (subcmd, eTokens) = tokenize commandDefs ["foo", "--", "-a", "bar"] - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [] tokens) - $expect (equal ["foo", "-a", "bar"] args) + let Right (Tokens tokens args) = eTokens + equalTokens [("test.x", TokenUnary "-x")] tokens + shouldBe ["foo", "bar"] args + do + let (subcmd, eTokens) = tokenize commandDefs ["-xy", "foo", "bar"] + shouldBe Nothing subcmd + right eTokens -test_Subcommand :: Test -test_Subcommand = assertions "subcommand" $ do - do - let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub1", "-d", "foo", "--long-e", "bar"] - $expect (equal (Just "sub1") subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "-x"), ("sub.d", Token "-d" "foo"), ("sub.e", TokenUnary "--long-e")] tokens) - $expect (equal ["bar"] args) - do - let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub2", "-d", "foo", "--long-e", "bar"] - $expect (equal (Just "sub2") subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.x", TokenUnary "-x"), ("sub.d", TokenUnary "-d"), ("sub.e", TokenUnary "--long-e")] tokens) - $expect (equal ["foo", "bar"] args) + let Right (Tokens tokens args) = eTokens + equalTokens [("test.x", TokenUnary "-x"), ("test.y", TokenUnary "-y")] tokens + shouldBe ["foo", "bar"] args -test_SubcommandUnknown:: Test -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_ShortFlagDuplicate :: Spec +test_ShortFlagDuplicate = specify "short-flag-duplicate" do + do + let (subcmd, eTokens) = tokenize commandDefs ["-x", "-x"] + shouldBe Nothing subcmd + right eTokens -test_Unicode :: Test -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 (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "-\12354" "foo")] tokens) - $expect (equal ["bar"] args) - do - let (subcmd, eTokens) = tokenize unicodeDefs longArgs - $expect (equal Nothing subcmd) - $assert (right eTokens) - - let Right (Tokens tokens args) = eTokens - $expect (equalTokens [("test.a", Token "--long-\12354" "foo")] tokens) - $expect (equal ["bar"] args) + let Right (Tokens tokens _args) = eTokens + equalTokens [("test.x", TokenUnary "-x"), ("test.x", TokenUnary "-x")] tokens + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-a", "foo"] + shouldBe Nothing subcmd + right eTokens -equalTokens :: [(String, Token)] -> [([OptionKey], Token)] -> Assertion -equalTokens tokens = equal ([([OptionKey k], t) | (k, t) <- tokens]) + let Right (Tokens tokens _args) = eTokens + equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "-a" "foo")] tokens + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-afoo"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens _args) = eTokens + equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "-a" "foo")] tokens + +test_LongFlag :: Spec +test_LongFlag = specify "long-flag" do + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-a", "foo", "bar"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.a", Token "--long-a" "foo")] tokens + shouldBe ["bar"] args + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-a=foo", "bar"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.a", Token "--long-a" "foo")] tokens + shouldBe ["bar"] args + +test_LongFlagUnknown :: Spec +test_LongFlagUnknown = specify "long-flag-unknown" do + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-c", "foo", "bar"] + shouldBe Nothing subcmd + left eTokens + + let Left err = eTokens + shouldBe "Unknown flag --long-c" err + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-c=foo", "bar"] + shouldBe Nothing subcmd + left eTokens + + let Left err = eTokens + shouldBe "Unknown flag --long-c" err + +test_LongFlagMissing :: Spec +test_LongFlagMissing = specify "long-flag-missing" do + let (subcmd, eTokens) = tokenize commandDefs ["--long-a"] + shouldBe Nothing subcmd + left eTokens + + let Left err = eTokens + shouldBe "The flag --long-a requires a parameter." err + +test_LongFlagUnary :: Spec +test_LongFlagUnary = specify "long-flag-unary" do + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-x", "foo", "bar"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.x", TokenUnary "--long-x")] tokens + shouldBe ["foo", "bar"] args + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-x=foo", "bar"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.x", Token "--long-x" "foo")] tokens + shouldBe ["bar"] args + +test_LongFlagDuplicate :: Spec +test_LongFlagDuplicate = specify "long-flag-duplicate" do + do + let (subcmd, eTokens) = tokenize commandDefs ["-x", "--long-x"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens _args) = eTokens + equalTokens [("test.x", TokenUnary "-x"), ("test.x", TokenUnary "--long-x")] tokens + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a", "foo"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens _args) = eTokens + equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "--long-a" "foo")] tokens + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a=foo"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens _args) = eTokens + equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "--long-a" "foo")] tokens + +test_EndFlags :: Spec +test_EndFlags = specify "end-flags" do + let (subcmd, eTokens) = tokenize commandDefs ["foo", "--", "-a", "bar"] + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [] tokens + shouldBe ["foo", "-a", "bar"] args + +test_Subcommand :: Spec +test_Subcommand = specify "subcommand" do + do + let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub1", "-d", "foo", "--long-e", "bar"] + shouldBe (Just "sub1") subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.x", TokenUnary "-x"), ("sub.d", Token "-d" "foo"), ("sub.e", TokenUnary "--long-e")] tokens + shouldBe ["bar"] args + do + let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub2", "-d", "foo", "--long-e", "bar"] + shouldBe (Just "sub2") subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.x", TokenUnary "-x"), ("sub.d", TokenUnary "-d"), ("sub.e", TokenUnary "--long-e")] tokens + shouldBe ["foo", "bar"] args + +test_SubcommandUnknown :: Spec +test_SubcommandUnknown = specify "subcommand-unknown" do + let (subcmd, eTokens) = tokenize subcommandDefs ["foo"] + shouldBe Nothing subcmd + left eTokens + + let Left err = eTokens + shouldBe "Unknown subcommand \"foo\"." err + +test_Unicode :: Spec +test_Unicode = specify "unicode" do + let shortArgs = ["-\12354", "foo", "bar"] + let longArgs = ["--long-\12354=foo", "bar"] + do + let (subcmd, eTokens) = tokenize unicodeDefs shortArgs + shouldBe Nothing subcmd + case eTokens of + Left err -> error err + Right _ -> return () + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.a", Token "-\12354" "foo")] tokens + shouldBe ["bar"] args + do + let (subcmd, eTokens) = tokenize unicodeDefs longArgs + shouldBe Nothing subcmd + right eTokens + + let Right (Tokens tokens args) = eTokens + equalTokens [("test.a", Token "--long-\12354" "foo")] tokens + shouldBe ["bar"] args + +equalTokens :: [(String, Token)] -> [([OptionKey], Token)] -> Expectation +equalTokens tokens = shouldBe ([([OptionKey k], t) | (k, t) <- tokens]) diff --git a/tests/OptionsTests/Util.hs b/tests/OptionsTests/Util.hs --- a/tests/OptionsTests/Util.hs +++ b/tests/OptionsTests/Util.hs @@ -1,141 +1,57 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -- Copyright (C) 2012 John Millikin -- -- See license.txt for details -module OptionsTests.Util - ( suite_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 - -suite_Util :: Suite -suite_Util = suite "util" - [ test_ValidFieldName - , test_ValidShortFlag - , test_ValidLongFlag - , test_HasDuplicates -#if defined(OPTIONS_ENCODING_UTF8) - , property "decodeUtf8" prop_DecodeUtf8 -#endif - ] +module OptionsTests.Util (suite_Util) where -test_ValidFieldName :: Test -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")) +import Options.Util +import Test.Hspec -test_ValidShortFlag :: Test -test_ValidShortFlag = assertions "validShortFlag" $ do - $expect (validShortFlag 'a') - $expect (validShortFlag 'A') - $expect (validShortFlag '0') - $expect (validShortFlag '\12354') - $expect (not (validShortFlag ' ')) - $expect (not (validShortFlag '-')) +suite_Util :: Spec +suite_Util = context "util" do + test_ValidFieldName + test_ValidShortFlag + test_ValidLongFlag + test_HasDuplicates -test_ValidLongFlag :: Test -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_ValidFieldName :: Spec +test_ValidFieldName = specify "validFieldName" do + shouldBe True $ validFieldName "a" + shouldBe True $ validFieldName "abc" + shouldBe True $ validFieldName "_abc_" + shouldBe True $ validFieldName "abc'" + shouldBe True $ validFieldName "\12354" + shouldBe False $ validFieldName "" + shouldBe False $ validFieldName "'a" + shouldBe False $ validFieldName "a b" + shouldBe False $ validFieldName "Ab" -test_HasDuplicates :: Test -test_HasDuplicates = assertions "hasDuplicates" $ do - $expect (not (hasDuplicates ([] :: [Char]))) - $expect (not (hasDuplicates ['a', 'b'])) - $expect (hasDuplicates ['a', 'b', 'a']) +test_ValidShortFlag :: Spec +test_ValidShortFlag = specify "validShortFlag" do + shouldBe True $ validShortFlag 'a' + shouldBe True $ validShortFlag 'A' + shouldBe True $ validShortFlag '0' + shouldBe True $ validShortFlag '\12354' + shouldBe False $ validShortFlag ' ' + shouldBe False $ validShortFlag '-' -#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 +test_ValidLongFlag :: Spec +test_ValidLongFlag = specify "validLongFlag" do + shouldBe True $ validLongFlag "a" + shouldBe True $ validLongFlag "A" + shouldBe True $ validLongFlag "abc" + shouldBe True $ validLongFlag "0" + shouldBe True $ validLongFlag "012" + shouldBe True $ validLongFlag "a-b" + shouldBe True $ validLongFlag "a_b" + shouldBe True $ validLongFlag "\12354bc" + shouldBe False $ validLongFlag "" + shouldBe False $ validLongFlag "a b" + shouldBe False $ validLongFlag "a+b" + shouldBe False $ validLongFlag "-" + shouldBe False $ validLongFlag "--" -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 +test_HasDuplicates :: Spec +test_HasDuplicates = specify "hasDuplicates" do + shouldBe False $ hasDuplicates ([] :: [Char]) + shouldBe False $ hasDuplicates ['a', 'b'] + shouldBe True $ hasDuplicates ['a', 'b', 'a']