packages feed

options 1.0 → 1.1

raw patch · 10 files changed

+245/−76 lines, 10 files

Files

lib/Options.hs view
@@ -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
lib/Options/Help.hs view
@@ -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
lib/Options/Tokenize.hs view
@@ -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
lib/Options/Types.hs view
@@ -30,6 +30,7 @@ 	| OptionKeyHelpSummary 	| OptionKeyHelpGroup String 	| OptionKeyGenerated Integer+	| OptionKeyIgnored 	deriving (Eq, Ord, Show)  data Location = Location
lib/Options/Util.hs view
@@ -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
options.cabal view
@@ -1,5 +1,5 @@ name: options-version: 1.0+version: 1.1 license: MIT license-file: license.txt author: John Millikin <john@john-millikin.com>@@ -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
tests/OptionsTests.hs view
@@ -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
+ tests/OptionsTests/Api.hs view
@@ -0,0 +1,82 @@+{-# 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++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))
tests/OptionsTests/Help.hs view
@@ -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))
tests/OptionsTests/Tokenize.hs view
@@ -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])