diff --git a/lib/Options.hs b/lib/Options.hs --- a/lib/Options.hs +++ b/lib/Options.hs @@ -140,10 +140,14 @@ , 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 @@ -157,6 +161,7 @@ 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'. @@ -181,7 +186,7 @@ -- 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)) +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 @@ -230,6 +235,12 @@ -- | 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 a new option type with the given name, default, and behavior. @@ -238,7 +249,7 @@ -> (String -> Either String val) -- ^ Parser -> (val -> String) -- ^ Formatter -> OptionType val -optionType name def parse show' = OptionType name def parse show' Nothing +optionType name def parse show' = OptionType name def parse show' Nothing Nothing class SimpleOptionType a where simpleOptionType :: OptionType a @@ -619,16 +630,34 @@ , 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 tok -> case tok of - TokenUnary flagName -> case optionTypeUnary t of - Nothing -> Left ("The flag " ++ flagName ++ " requires an argument.") - Just val -> Right (key+1, val) - Token flagName rawValue -> case optionTypeParse t rawValue of - Left err -> Left ("Value for flag " ++ flagName ++ " is invalid: " ++ err) + 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, @@ -670,12 +699,62 @@ , optionLocation :: Maybe Location } --- * Each option defines at least one short or long flag. --- * There are no duplicate short or long flags, except between subcommands. --- * All short or long flags have a reasonable name. --- * All subcommands have unique names. validateOptionDefs :: [OptionInfo] -> [(String, [OptionInfo])] -> Either String OptionDefinitions -validateOptionDefs cmdInfos subInfos = Right (addHelpFlags (OptionDefinitions cmdInfos subInfos)) -- TODO +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 diff --git a/lib/Options/Help.hs b/lib/Options/Help.hs --- a/lib/Options/Help.hs +++ b/lib/Options/Help.hs @@ -110,9 +110,9 @@ helpKeys = do (k, _) <- tokensList tokens case k of - OptionKeyHelpSummary -> return HelpSummary - OptionKeyHelpGroup "all" -> return HelpAll - OptionKeyHelpGroup name -> return (HelpGroup name) + [OptionKeyHelpSummary] -> return HelpSummary + [OptionKeyHelpGroup "all"] -> return HelpAll + [OptionKeyHelpGroup name] -> return (HelpGroup name) _ -> [] helpFor :: HelpFlag -> OptionDefinitions -> Maybe String -> String diff --git a/lib/Options/Tokenize.hs b/lib/Options/Tokenize.hs --- a/lib/Options/Tokenize.hs +++ b/lib/Options/Tokenize.hs @@ -16,7 +16,6 @@ import Control.Monad.State import Data.Functor.Identity import qualified Data.Map -import qualified Data.Set as Set import Options.Types import Options.Util @@ -31,21 +30,23 @@ tokenFlagName (Token s _) = s data Tokens = Tokens - { tokensList :: [(OptionKey, Token)] + { tokensList :: [([OptionKey], Token)] , tokensArgv :: [String] } deriving (Show) -tokensMap :: Tokens -> Data.Map.Map OptionKey Token -tokensMap = Data.Map.fromList . tokensList +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)] - , stSeen :: Set.Set OptionKey - , stShortKeys :: Data.Map.Map Char (OptionKey, OptionInfo) - , stLongKeys :: Data.Map.Map String (OptionKey, OptionInfo) + , stOpts :: [([OptionKey], Token)] + , stShortKeys :: Data.Map.Map Char ([OptionKey], OptionInfo) + , stLongKeys :: Data.Map.Map String ([OptionKey], OptionInfo) , stSubcommands :: [(String, [OptionInfo])] , stSubCmd :: Maybe String } @@ -67,7 +68,6 @@ { stArgv = argv , stArgs = [] , stOpts = [] - , stSeen = Set.empty , stShortKeys = toShortKeys options , stLongKeys = toLongKeys options , stSubcommands = subcommands @@ -108,24 +108,21 @@ addArg :: String -> Tok () addArg s = modify (\st -> st { stArgs = stArgs st ++ [s] }) -addOpt :: OptionKey -> Token -> Tok () -addOpt key val = do - seen <- gets stSeen - if Set.member key seen - -- TODO: include old and new values? - then throwError ("Multiple values for flag " ++ tokenFlagName val ++ " were provided.") - else modify (\st -> st - { stOpts = (key, val) : stOpts st - , stSeen = Set.insert key (stSeen st) - }) +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.union (stShortKeys st) (toShortKeys opts) - , stLongKeys = Data.Map.union (stLongKeys st) (toLongKeys opts) + , stShortKeys = Data.Map.unionWith unionKeys (stShortKeys st) (toShortKeys opts) + , stLongKeys = Data.Map.unionWith unionKeys (stLongKeys st) (toLongKeys opts) } +unionKeys :: ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) -> ([OptionKey], OptionInfo) +unionKeys = undefined + parseLong :: String -> Tok () parseLong optName = do longKeys <- gets stLongKeys @@ -133,18 +130,18 @@ (before, after) -> case after of '=' : value -> case Data.Map.lookup before longKeys of Nothing -> throwError ("Unknown flag --" ++ before) - Just (key, info) -> if optionInfoUnaryOnly info + Just (keys, info) -> if optionInfoUnaryOnly info then throwError ("Flag --" ++ before ++ " takes no parameters.") - else addOpt key (Token ("--" ++ before) value) + else addOpt keys (Token ("--" ++ before) value) _ -> case Data.Map.lookup optName longKeys of Nothing -> throwError ("Unknown flag --" ++ optName) - Just (key, info) -> if optionInfoUnary info - then addOpt key (TokenUnary ("--" ++ 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 key (Token ("--" ++ optName) value) + Just value -> addOpt keys (Token ("--" ++ optName) value) parseShort :: Char -> String -> Tok () parseShort optChar optValue = do @@ -152,11 +149,11 @@ shortKeys <- gets stShortKeys case Data.Map.lookup optChar shortKeys of Nothing -> throwError ("Unknown flag " ++ optName) - Just (key, info) -> if optionInfoUnary info + 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 key (TokenUnary optName) + addOpt keys (TokenUnary optName) case optValue of [] -> return () nextChar:nextValue -> parseShort nextChar nextValue @@ -165,20 +162,20 @@ next <- nextItem case next of Nothing -> throwError ("The flag " ++ optName ++ " requires a parameter.") - Just value -> addOpt key (Token optName value) - _ -> addOpt key (Token optName optValue) + Just value -> addOpt keys (Token optName value) + _ -> addOpt keys (Token optName optValue) -toShortKeys :: [OptionInfo] -> Data.Map.Map Char (OptionKey, OptionInfo) -toShortKeys opts = Data.Map.fromList $ do +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)) + return (flag, ([optionInfoKey opt], opt)) -toLongKeys :: [OptionInfo] -> Data.Map.Map String (OptionKey, OptionInfo) -toLongKeys opts = Data.Map.fromList $ do +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)) + return (flag, ([optionInfoKey opt], opt)) throwError :: String -> Tok a throwError = Tok . Control.Monad.Error.throwError diff --git a/lib/Options/Types.hs b/lib/Options/Types.hs --- a/lib/Options/Types.hs +++ b/lib/Options/Types.hs @@ -30,6 +30,7 @@ | OptionKeyHelpSummary | OptionKeyHelpGroup String | OptionKeyGenerated Integer + | OptionKeyIgnored deriving (Eq, Ord, Show) data Location = Location diff --git a/lib/Options/Util.hs b/lib/Options/Util.hs --- a/lib/Options/Util.hs +++ b/lib/Options/Util.hs @@ -55,3 +55,10 @@ hasDuplicates :: Ord a => [a] -> Bool hasDuplicates xs = Set.size (Set.fromList xs) /= length xs + +mapEither :: (a -> Either err b) -> [a] -> Either err [b] +mapEither fn = loop [] where + loop acc [] = Right (reverse acc) + loop acc (a:as) = case fn a of + Left err -> Left err + Right b -> loop (b:acc) as diff --git a/options.cabal b/options.cabal --- a/options.cabal +++ b/options.cabal @@ -1,5 +1,5 @@ name: options -version: 1.0 +version: 1.1 license: MIT license-file: license.txt author: John Millikin @@ -78,7 +78,7 @@ source-repository this type: git location: https://john-millikin.com/code/haskell-options/ - tag: haskell-options_1.0 + tag: haskell-options_1.1 library ghc-options: -Wall -O2 @@ -132,6 +132,7 @@ , transformers >= 0.2 other-modules: + OptionsTests.Api OptionsTests.Help OptionsTests.OptionTypes OptionsTests.StringParsing diff --git a/tests/OptionsTests.hs b/tests/OptionsTests.hs --- a/tests/OptionsTests.hs +++ b/tests/OptionsTests.hs @@ -8,6 +8,7 @@ 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) @@ -16,7 +17,8 @@ tests :: [Suite] tests = - [ suite_Help + [ suite_Api + , suite_Help , suite_OptionTypes , suite_StringParsing , suite_Tokenize diff --git a/tests/OptionsTests/Api.hs b/tests/OptionsTests/Api.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/Api.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2014 John Millikin +-- +-- See license.txt for details +module OptionsTests.Api + ( suite_Api + ) where + +import Control.Applicative +import Test.Chell + +import Options + +suite_Api :: Suite +suite_Api = suite "api" + test_RepeatedFlags + test_CompatibleDuplicateFlags + test_ConflictingDuplicateFlags + +data RepeatedStringOpts = RepeatedStringOpts [String] + deriving (Eq, Show) + +repeatedStringList :: OptionType [String] +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'] + }) + +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"]))) + +data CompatibleDuplicateOpts = CompatibleDuplicateOpts SubOpts1 SubOpts1 + deriving (Eq, Show) + +instance Options CompatibleDuplicateOpts where + defineOptions = pure CompatibleDuplicateOpts + <*> defineOptions + <*> defineOptions + +data ConflictingDuplicateOpts = ConflictingDuplicateOpts SubOpts1 SubOpts2 + deriving (Eq, Show) + +instance Options ConflictingDuplicateOpts where + defineOptions = pure ConflictingDuplicateOpts + <*> defineOptions + <*> defineOptions + +data SubOpts1 = SubOpts1 Integer + deriving (Eq, Show) + +data SubOpts2 = SubOpts2 Integer + deriving (Eq, Show) + +instance Options SubOpts1 where + defineOptions = pure SubOpts1 + <*> simpleOption "int" 0 "" + +instance Options SubOpts2 where + 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_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)) diff --git a/tests/OptionsTests/Help.hs b/tests/OptionsTests/Help.hs --- a/tests/OptionsTests/Help.hs +++ b/tests/OptionsTests/Help.hs @@ -186,7 +186,7 @@ test_CheckHelpFlag :: Test test_CheckHelpFlag = assertions "checkHelpFlag" $ do - let checkFlag keys = equal (checkHelpFlag (Tokens [(k, TokenUnary "-h") | k <- keys] [])) + let checkFlag keys = equal (checkHelpFlag (Tokens [([k], TokenUnary "-h") | k <- keys] [])) $expect (checkFlag [] Nothing) $expect (checkFlag [OptionKeyHelpSummary] (Just HelpSummary)) diff --git a/tests/OptionsTests/Tokenize.hs b/tests/OptionsTests/Tokenize.hs --- a/tests/OptionsTests/Tokenize.hs +++ b/tests/OptionsTests/Tokenize.hs @@ -147,24 +147,24 @@ do let (subcmd, eTokens) = tokenize commandDefs ["-x", "-x"] $expect (equal Nothing subcmd) - $assert (left eTokens) + $assert (right eTokens) - let Left err = eTokens - $expect (equal "Multiple values for flag -x were provided." err) + 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 (left eTokens) + $assert (right eTokens) - let Left err = eTokens - $expect (equal "Multiple values for flag -a were provided." err) + 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 (left eTokens) + $assert (right eTokens) - let Left err = eTokens - $expect (equal "Multiple values for flag -a were provided." err) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "-a" "foo")] tokens) test_LongFlag :: Test test_LongFlag = assertions "long-flag" $ do @@ -235,24 +235,24 @@ do let (subcmd, eTokens) = tokenize commandDefs ["-x", "--long-x"] $expect (equal Nothing subcmd) - $assert (left eTokens) + $assert (right eTokens) - let Left err = eTokens - $expect (equal "Multiple values for flag --long-x were provided." err) + 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 (left eTokens) + $assert (right eTokens) - let Left err = eTokens - $expect (equal "Multiple values for flag --long-a were provided." err) + 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 (left eTokens) + $assert (right eTokens) - let Left err = eTokens - $expect (equal "Multiple values for flag --long-a were provided." err) + let Right (Tokens tokens args) = eTokens + $expect (equalTokens [("test.a", Token "-a" "foo"), ("test.a", Token "--long-a" "foo")] tokens) test_EndFlags :: Test test_EndFlags = assertions "end-flags" $ do @@ -321,5 +321,5 @@ $expect (equalTokens [("test.a", Token "--long-\12354" "foo")] tokens) $expect (equal ["bar"] args) -equalTokens :: [(String, Token)] -> [(OptionKey, Token)] -> Assertion -equalTokens tokens = equal ([(OptionKey k, t) | (k, t) <- tokens]) +equalTokens :: [(String, Token)] -> [([OptionKey], Token)] -> Assertion +equalTokens tokens = equal ([([OptionKey k], t) | (k, t) <- tokens])