packages feed

options 1.2.1.1 → 1.2.1.2

raw patch · 24 files changed

+3109/−3133 lines, 24 filesdep +hspecdep +optionsdep +patiencedep −bytestringdep −chelldep −chell-quickcheckdep ~basedep ~containersdep ~monads-tfsetup-changednew-uploader

Dependencies added: hspec, options, patience

Dependencies removed: bytestring, chell, chell-quickcheck, transformers

Dependency ranges changed: base, containers, monads-tf

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− cbits/hoehrmann_utf8.c 
@@ -1,60 +0,0 @@-/**- * Copyright (c) 2008-2010 Björn Höhrmann <bjoern@hoehrmann.de>- *- * Permission is hereby granted, free of charge, to any person obtaining- * a copy of this software and associated documentation files (the- * "Software"), to deal in the Software without restriction, including- * without limitation the rights to use, copy, modify, merge, publish,- * distribute, sublicense, and/or sell copies of the Software, and to- * permit persons to whom the Software is furnished to do so, subject to- * the following conditions:- *- * The above copyright notice and this permission notice shall be included- * in all copies or substantial portions of the Software.- *- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,- * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF- * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.- * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY- * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,- * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE- * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.-**/--#define UTF8_ACCEPT 0-#define UTF8_REJECT 12--static const uint8_t utf8d[] = {-  /* The first part of the table maps bytes to character classes that-   * to reduce the size of the transition table and create bitmasks.-   */-   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-   1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,  9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,-   7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,  7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,-   8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,  2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,-  10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,--  /* The second part is a transition table that maps a combination-   * of a state of the automaton and a character class to a state.-   */-   0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,-  12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,-  12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,-  12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,-  12,36,12,12,12,12,12,12,12,12,12,12,-};--static inline uint32_t-decode(uint32_t* state, uint32_t* codep, uint32_t byte) {-  uint32_t type = utf8d[byte];--  *codep = (*state != UTF8_ACCEPT) ?-    (byte & 0x3fu) | (*codep << 6) :-    (0xff >> type) & (byte);--  *state = utf8d[256 + *state + type];-  return *state;-}
− cbits/utf8.c 
@@ -1,102 +0,0 @@-#include <stdint.h>-#include "hoehrmann_utf8.c"--#include <stdio.h>--/* Decode a UTF8-encoded string to UCS4 using the Höhrmann decoder. Any- * invalid bytes are stored using GHC 7.4's encoding for mixed-use strings.- *- * 'len' is the length of both 'utf8' and 'out'.- *- * Returns the number of items written to *out.- */-int hsoptions_decode_string(uint8_t *utf8, uint32_t *out, int len)-{-	uint32_t state = UTF8_ACCEPT;-	uint8_t *utf8_end = utf8 + len;-	uint32_t codepoint = 0;-	uint32_t *out_orig = out;-	uint8_t *started_accept = utf8;-	-	while (utf8 < utf8_end)-	{-#if defined(__i386__) || defined(__x86_64__)-		/* Performance improvement from Bryan O'Sullivan.-		 *-		 * If some chunk of bytes is ASCII, it can be quickly pushed-		 * off into the output buffer without going through the UTF8-		 * decoder. On little-endian systems, pure-ASCII text will-		 * have a mask of 0x80808080.-		 */-		if (state == UTF8_ACCEPT)-		{-			while (utf8 < utf8_end - 4)-			{-				codepoint = *((uint32_t *) utf8);-				if ((codepoint & 0x80808080) != 0)-				{ break; }-				-				utf8 += 4;-				*out++ = codepoint & 0xFF;-				*out++ = (codepoint >> 8) & 0xFF;-				*out++ = (codepoint >> 16) & 0xFF;-				*out++ = (codepoint >> 24) & 0xFF;-			}-			started_accept = utf8;-		}-#endif-		switch (decode(&state, &codepoint, *utf8))-		{-		case UTF8_ACCEPT:-			/* Read a codepoint succesfully. Copy it out and-			 * continue.-			 */-			*out++ = codepoint;-			started_accept = utf8++;-			break;-		case UTF8_REJECT:-			/* The first byte of a new character was invalid.-			 * Escape it and begin again.-			 */-			if (started_accept == utf8)-			{-				*out++ = (uint32_t) (*utf8++) + 0xDC00;-				started_accept = utf8;-			}-			-			/* The decoder consumed some bytes before failing.-			 * Backtrack to escape everything after the last-			 * successfully read codepoint.-			 */-			else while (started_accept < utf8)-			{-				*out++ = (uint32_t) (*started_accept++) + 0xDC00;-			}-			-			/* Continue looking for valid UTF8 sequences in the-			 * input buffer.-			 */-			state = UTF8_ACCEPT;-			break;-		default:-			/* Decoder needs more input */-			utf8++;-			break;-		}-	}-	-	/* See comments in case UTF8_REJECT. */-	if (state != UTF8_ACCEPT)-	{-		if (started_accept == utf8)-		{-			*out++ = (uint32_t) (*utf8) + 0xDC00;-		}-		else while (started_accept < utf8)-		{-			*out++ = (uint32_t) (*started_accept++) + 0xDC00;-		}-	}-	-	return out - out_orig;-}
+ changelog.md view
@@ -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
+ internal/Options/Help.hs view
@@ -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)]
+ internal/Options/Tokenize.hs view
@@ -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
+ internal/Options/Types.hs view
@@ -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)
+ internal/Options/Util.hs view
@@ -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
lib/Options.hs view
@@ -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
− lib/Options/Help.hs 
@@ -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)]
− lib/Options/Tokenize.hs 
@@ -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
− lib/Options/Types.hs 
@@ -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)
− lib/Options/Util.hs 
@@ -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
options.cabal view
@@ -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 <john@john-millikin.com>-maintainer: John Millikin <john@john-millikin.com>-build-type: Simple-cabal-version: >= 1.8+maintainer: Chris Martin <chris@typeclasses.com>+ 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-  &#x20;   &#x7b; optMessage :: String-  &#x20;   , optQuiet :: Bool-  &#x20;   &#x7d;-  .-  instance 'Options' MainOptions where-  &#x20;   defineOptions = pure MainOptions-  &#x20;       \<*\> simpleOption \"message\" \"Hello world!\"-  &#x20;           \"A message to show the user.\"-  &#x20;       \<*\> simpleOption \"quiet\" False-  &#x20;           \"Whether to be quiet.\"-  .-  main :: IO ()-  main = runCommand $ \\opts args -> do-  &#x20;   if optQuiet opts-  &#x20;       then return ()-  &#x20;       else putStrLn (optMessage opts)-  @-  .-  >$ ./hello-  >Hello world!-  >$ ./hello --message='ciao mondo'-  >ciao mondo-  >$ ./hello --quiet-  >$-  .-  In addition, this library will automatically create documentation options-  such as @--help@ and @--help-all@:-  .-  >$ ./hello --help-  >Help Options:-  >  -h, --help-  >    Show option summary.-  >  --help-all-  >    Show all help options.-  >-  >Application Options:-  >  --message :: 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
+ readme.md view
@@ -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+```
+ tests/Chell.hs view
@@ -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
+ tests/Main.hs view
@@ -0,0 +1,21 @@+-- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>+--+-- 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
− tests/OptionsTests.hs 
@@ -1,29 +0,0 @@--- Copyright (C) 2012 John Millikin <jmillikin@gmail.com>------ See license.txt for details-module Main-	( tests-	, main-	) where--import           Test.Chell (Suite, defaultMain)--import           OptionsTests.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
tests/OptionsTests/Api.hs view
@@ -1,83 +1,86 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}- -- Copyright (C) 2014 John Millikin <jmillikin@gmail.com> -- -- 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)
tests/OptionsTests/Help.hs view
@@ -1,399 +1,473 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}- -- Copyright (C) 2012 John Millikin <jmillikin@gmail.com> -- -- 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"))
tests/OptionsTests/OptionTypes.hs view
@@ -1,317 +1,307 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}- -- Copyright (C) 2012 John Millikin <jmillikin@gmail.com> -- -- 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\"}."
tests/OptionsTests/StringParsing.hs view
@@ -1,77 +1,59 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}- -- Copyright (C) 2012 John Millikin <jmillikin@gmail.com> -- -- 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
tests/OptionsTests/Tokenize.hs view
@@ -1,326 +1,319 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}- -- Copyright (C) 2012 John Millikin <jmillikin@gmail.com> -- -- 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])
tests/OptionsTests/Util.hs view
@@ -1,141 +1,57 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}- -- Copyright (C) 2012 John Millikin <jmillikin@gmail.com> -- -- 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']