diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,12 @@ +### 0.7.0.4 + +- Fix the test suite when run from a distributed tarball [#21] +- Make the test suite more developer-friendly + ### 0.7.0.3 - Fix `isPresent` treatment of repeatable arguments/options [#15] -- Fix build failure for stackage inclusion +- Fix build failure for stackage inclusion [#20] ### 0.7.0.2 diff --git a/System/Console/Docopt/ApplicativeParsec.hs b/System/Console/Docopt/ApplicativeParsec.hs --- a/System/Console/Docopt/ApplicativeParsec.hs +++ b/System/Console/Docopt/ApplicativeParsec.hs @@ -8,5 +8,4 @@ ) where import Control.Applicative hiding (optional, (<|>)) -import Control.Monad (MonadPlus(..), ap) import Text.ParserCombinators.Parsec hiding (many) diff --git a/System/Console/Docopt/ParseUtils.hs b/System/Console/Docopt/ParseUtils.hs --- a/System/Console/Docopt/ParseUtils.hs +++ b/System/Console/Docopt/ParseUtils.hs @@ -15,6 +15,7 @@ -- * Constants +lowers, uppers, letters, numerics, specialChars, alphanumerics, alphanumSpecial :: String lowers = ['a'..'z'] uppers = ['A'..'Z'] letters = lowers++uppers @@ -27,7 +28,7 @@ -- * Basic Parsers caseInsensitive :: String -> CharParser u String -caseInsensitive = sequence . (map (\c -> (char $ toLower c) <|> (char $ toUpper c))) +caseInsensitive = mapM (\c -> char (toLower c) <|> char (toUpper c)) lookAhead_ :: CharParser u a -> CharParser u () lookAhead_ p = do lookAhead p @@ -37,8 +38,8 @@ isNotFollowedBy p = option False (notFollowedBy p >> return True) isInlineSpace :: Char -> Bool -isInlineSpace c = not (c `elem` "\n\r") - && (isSpace c) +isInlineSpace c = notElem c "\n\r" + && isSpace c inlineSpace :: CharParser u Char inlineSpace = satisfy isInlineSpace @@ -57,36 +58,40 @@ spaces1 = skipMany1 (satisfy isSpace) ">=1 spaces" +endline :: CharParser u Char endline = inlineSpaces >> newline -optionalEndline = inlineSpaces >> (optional newline) +optionalEndline :: CharParser u () +optionalEndline = inlineSpaces >> optional newline + +pipe :: CharParser u Char pipe = char '|' "'|'" ellipsis :: CharParser u String ellipsis = inlineSpaces >> string "..." "'...'" - +manyTill1 :: CharParser u a -> CharParser u b -> CharParser u [a] manyTill1 p end = do - first <- p + first <- p rest <- manyTill p end return $ first : rest --- |@skipUntil p@ ignores everything that comes before `p`. +-- |@skipUntil p@ ignores everything that comes before `p`. -- Returns what `p` returns. skipUntil :: Show a => CharParser u a -> CharParser u () skipUntil p = skipMany (notFollowedBy p >> anyChar) pGroup :: Char -> CharParser u a -> Char -> CharParser u [a] -pGroup beg elemParser end = between (char beg) (inlineSpaces >> char end) - $ (inlineSpaces >> notFollowedBy pipe >> elemParser) +pGroup beg elemParser end = between (char beg) (inlineSpaces >> char end) + $ (inlineSpaces >> notFollowedBy pipe >> elemParser) `sepBy` (inlineSpaces >> pipe) betweenS :: String -> String -> CharParser u a -> CharParser u [a] betweenS b e p = between begin end manyP where begin = try $ string b - end = try $ inlineSpaces >> (string e) + end = try $ inlineSpaces >> string e manyP = p `sepBy` inlineSpaces1 diff --git a/System/Console/Docopt/Types.hs b/System/Console/Docopt/Types.hs --- a/System/Console/Docopt/Types.hs +++ b/System/Console/Docopt/Types.hs @@ -1,12 +1,10 @@ module System.Console.Docopt.Types where -import Data.Ord (comparing) import Data.Map (Map) import qualified Data.Map as M import Data.List (nub) -import System.Console.Docopt.ParseUtils -- * Usage expression Types @@ -21,9 +19,9 @@ deriving (Show, Eq) atoms :: Eq a => Pattern a -> [a] -atoms (Sequence ps) = foldl (++) [] $ map atoms ps -atoms (OneOf ps) = foldl (++) [] $ map atoms $ nub ps -atoms (Unordered ps) = foldl (++) [] $ map atoms $ nub ps +atoms (Sequence ps) = concatMap atoms ps +atoms (OneOf ps) = concatMap atoms $ nub ps +atoms (Unordered ps) = concatMap atoms $ nub ps atoms (Optional p) = atoms p atoms (Repeated p) = atoms p atoms (Atom a) = [a] diff --git a/System/Console/Docopt/UsageParse.hs b/System/Console/Docopt/UsageParse.hs --- a/System/Console/Docopt/UsageParse.hs +++ b/System/Console/Docopt/UsageParse.hs @@ -1,7 +1,6 @@ -module System.Console.Docopt.UsageParse +module System.Console.Docopt.UsageParse where -import Data.Map (Map) import qualified Data.Map as M import Data.Ord (comparing) import GHC.Exts (Down(..)) @@ -12,7 +11,7 @@ -- * Helpers --- | Flattens the top level of a Pattern, as long as that +-- | Flattens the top level of a Pattern, as long as that -- /does not/ alter the matching semantics of the Pattern flatten :: Pattern a -> Pattern a flatten (Sequence (x:[])) = x @@ -20,11 +19,14 @@ flatten (Unordered (x:[])) = x flatten x = x +flatSequence :: [Pattern a] -> Pattern a flatSequence = flatten . Sequence + +flatOneOf :: [Pattern a] -> Pattern a flatOneOf = flatten . OneOf --- * Pattern Parsers +-- * Pattern Parsers pLine :: CharParser OptInfoMap OptPattern pLine = flatten . OneOf <$> pSeq `sepBy1` (inlineSpaces >> pipe) @@ -40,25 +42,24 @@ pReqGroup = pGroup '(' pExpSeq ')' saveOptionsExpectVal :: (a -> Option) -> [(a, Bool)] -> CharParser OptInfoMap () -saveOptionsExpectVal t pairs = do - updateState $ \st -> foldl save st pairs +saveOptionsExpectVal t pairs = updateState $ \st -> foldl save st pairs where save infomap (name, optExpectsVal) = M.alter alterFn opt infomap where opt = t name alterFn oldval = Just $ case oldval of - Just oldinfo -> oldinfo {expectsVal = optExpectsVal || (expectsVal oldinfo)} + Just oldinfo -> oldinfo {expectsVal = optExpectsVal || expectsVal oldinfo} Nothing -> (fromSynList [opt]) {expectsVal = optExpectsVal} pShortOption :: CharParser OptInfoMap (Char, Bool) -pShortOption = try $ do char '-' - ch <- letter +pShortOption = try $ do char '-' + ch <- letter expectsVal <- pOptionArgument return (ch, expectsVal) pStackedShortOption :: CharParser OptInfoMap OptPattern -pStackedShortOption = try $ do +pStackedShortOption = try $ do char '-' - chars <- many1 $ letter + chars <- many1 letter lastExpectsVal <- pOptionArgument let (firstChars, lastChar) = (init chars, last chars) firstPairs = map (\x -> (x,False)) firstChars @@ -70,8 +71,8 @@ _ -> return $ Unordered $ map (Atom . ShortOption) chars pLongOption :: CharParser OptInfoMap (Name, Bool) -pLongOption = try $ do - string "--" +pLongOption = try $ do + string "--" name <- many1 $ oneOf alphanumerics expectsVal <- pOptionArgument --let expectsVal = False @@ -81,20 +82,20 @@ pAnyOption = try (string "options") pOptionArgument :: CharParser OptInfoMap Bool -- True if one is encountered, else False -pOptionArgument = option False $ try $ do - (try $ char '=') <|> try inlineSpace +pOptionArgument = option False $ try $ do + try (char '=') <|> try inlineSpace notFollowedBy (char '-') try pArgument <|> try (many1 $ oneOf alphanumerics) return True pArgument :: CharParser OptInfoMap String -pArgument = (try bracketStyle) <|> (try upperStyle) +pArgument = try bracketStyle <|> try upperStyle where bracketStyle = do - open <- char '<' + open <- char '<' name <- many $ oneOf alphanumSpecial close <- char '>' return name - upperStyle = do + upperStyle = do first <- oneOf uppers rest <- many $ oneOf $ uppers ++ numerics return $ first:rest @@ -104,16 +105,16 @@ -- '...' make an OptPattern Repeated if followed by ellipsis repeatable :: CharParser OptInfoMap OptPattern -> CharParser OptInfoMap OptPattern -repeatable p = do +repeatable p = do expct <- p - tryRepeat <- ((try $ (optional inlineSpace) >> ellipsis) >> (return Repeated)) <|> (return id) + tryRepeat <- (try (optional inlineSpace >> ellipsis) >> return Repeated) <|> return id return (tryRepeat expct) pExp :: CharParser OptInfoMap OptPattern pExp = inlineSpaces >> repeatable value where value = flatOneOf <$> pReqGroup -- <|> Optional . flatten . OneOf <$> betweenS "[(" ")]" pLine - <|> flatten . Sequence . (map Optional) <$> try (betweenS "[" "]" pExp) + <|> flatten . Sequence . map Optional <$> try (betweenS "[" "]" pExp) <|> Optional . flatten . OneOf <$> pOptGroup <|> return (Atom AnyOption) <* pAnyOption <|> pStackedShortOption @@ -132,9 +133,9 @@ -- | Ignores leading spaces and first word, then parses -- the rest of the usage line pUsageLine :: CharParser OptInfoMap OptPattern -pUsageLine = +pUsageLine = try $ do - inlineSpaces + inlineSpaces many1 (satisfy (not . isSpace)) -- prog name pLine @@ -143,7 +144,7 @@ many (notFollowedBy pUsageHeader >> anyChar) pUsageHeader optionalEndline - usageLines <- (pUsageLine `sepEndBy` endline) + usageLines <- pUsageLine `sepEndBy` endline return $ flatten . OneOf $ usageLines -- * Option Synonyms & Defaults Parsers @@ -154,10 +155,10 @@ begOptionLine = inlineSpaces >> lookAhead (char '-') >> return "-" pOptSynonyms :: CharParser OptInfoMap ([Option], Bool) -pOptSynonyms = do inlineSpaces +pOptSynonyms = do inlineSpaces pairs <- p `sepEndBy1` (optional (char ',') >> inlineSpace) let options = map fst pairs - expectsVal = or $ map snd pairs + expectsVal = any snd pairs return (options, expectsVal) where p = (\(c, ev) -> (ShortOption c, ev)) <$> pShortOption <|> (\(s, ev) -> (LongOption s, ev)) <$> pLongOption @@ -173,18 +174,17 @@ pOptDefault :: CharParser OptInfoMap (Maybe String) pOptDefault = do skipUntil (pDefaultTag <|> (newline >> begOptionLine)) - maybeDefault <- optionMaybe pDefaultTag - return maybeDefault + optionMaybe pDefaultTag pOptDescription :: CharParser OptInfoMap () pOptDescription = try $ do (syns, expectsVal) <- pOptSynonyms def <- pOptDefault skipUntil (newline >> begOptionLine) - updateState $ \infomap -> + updateState $ \infomap -> let optinfo = (fromSynList syns) {defaultVal = def, expectsVal = expectsVal} saveOptInfo infomap expct = M.insert expct optinfo infomap - in foldl saveOptInfo infomap syns + in foldl saveOptInfo infomap syns return () pOptDescriptions :: CharParser OptInfoMap OptInfoMap @@ -196,14 +196,14 @@ -- | Main usage parser: parses all of the usage lines into an Exception, --- and all of the option descriptions along with any accompanying +-- and all of the option descriptions along with any accompanying -- defaults, and returns both in a tuple pDocopt :: CharParser OptInfoMap OptFormat pDocopt = do optPattern <- pUsagePatterns optInfoMap <- pOptDescriptions let optPattern' = eagerSort $ expectSynonyms optInfoMap optPattern - saveCanRepeat pat el minfo = case minfo of + saveCanRepeat pat el minfo = case minfo of (Just info) -> Just $ info {isRepeated = canRepeat pat el} (Nothing) -> Just $ (fromSynList []) {isRepeated = canRepeat pat el} optInfoMap' = alterAllWithKey (saveCanRepeat optPattern') (atoms optPattern') optInfoMap @@ -221,26 +221,26 @@ expectSynonyms oim a@(Atom atom) = case atom of e@(Command ex) -> a e@(Argument ex) -> a - e@(AnyOption) -> flatten $ Unordered $ nub $ map Atom $ concat $ map synonyms (M.elems oim) - e@(LongOption ex) -> + e@AnyOption -> flatten $ Unordered $ nub $ map Atom $ concatMap synonyms (M.elems oim) + e@(LongOption ex) -> case synonyms <$> e `M.lookup` oim of Just syns -> flatten . OneOf $ map Atom syns Nothing -> a - e@(ShortOption c) -> + e@(ShortOption c) -> case synonyms <$> e `M.lookup` oim of Just syns -> flatten . OneOf $ map Atom syns Nothing -> a canRepeat :: Eq a => Pattern a -> a -> Bool -canRepeat pat target = +canRepeat pat target = case pat of (Sequence ps) -> canRepeatInside ps || (atomicOccurrences ps > 1) - (OneOf ps) -> foldl (||) False $ map ((flip canRepeat) target) ps + (OneOf ps) -> canRepeatInside ps (Unordered ps) -> canRepeatInside ps || (atomicOccurrences ps > 1) (Optional p) -> canRepeat p target - (Repeated p) -> target `elem` (atoms pat) + (Repeated p) -> target `elem` atoms pat (Atom a) -> False - where canRepeatInside ps = foldl (||) False $ map ((flip canRepeat) target) ps + where canRepeatInside = any (`canRepeat` target) atomicOccurrences ps = length $ filter (== target) $ atoms $ Sequence ps @@ -250,7 +250,7 @@ -- LongOption "option" > ShortOption 'o' == True -- Command "cmd" > Argument "arg" == True compareOptSpecificity :: Option -> Option -> Ordering -compareOptSpecificity optA optB = case optA of +compareOptSpecificity optA optB = case optA of LongOption a -> case optB of LongOption b -> comparingFirst length a b _ -> GT @@ -258,38 +258,38 @@ LongOption b -> LT ShortOption b -> compare a b _ -> GT - Command a -> case optB of + Command a -> case optB of LongOption b -> LT ShortOption b -> LT Command b -> comparingFirst length a b _ -> GT - Argument a -> case optB of + Argument a -> case optB of AnyOption -> GT Argument b -> comparingFirst length a b _ -> LT - AnyOption -> case optB of + AnyOption -> case optB of AnyOption -> EQ _ -> LT - where + where comparingFirst :: (Ord a, Ord b) => (a -> b) -> a -> a -> Ordering - comparingFirst p a1 a2 = + comparingFirst p a1 a2 = case compare (p a1) (p a2) of EQ -> compare a1 a2 o -> o -- | Sort an OptPattern such that more-specific patterns come first, --- while leaving the semantics of the pattern structure unchanged. +-- while leaving the semantics of the pattern structure unchanged. eagerSort :: OptPattern -> OptPattern -eagerSort pat = +eagerSort pat = case pat of Sequence ps -> Sequence $ map eagerSort ps OneOf ps -> OneOf $ map eagerSort - . sortBy (comparing $ Down . maxLength) + . sortBy (comparing $ Down . maxLength) . sortBy (comparing representativeAtom) $ ps Unordered ps -> Unordered $ map eagerSort ps Optional p -> Optional $ eagerSort p - Repeated p -> Repeated $ eagerSort p + Repeated p -> Repeated $ eagerSort p a@(Atom _) -> a where representativeAtom :: OptPattern -> Option @@ -307,7 +307,7 @@ Unordered ps -> sum $ map maxLength ps Optional p -> maxLength p Repeated p -> maxLength p - Atom a -> case a of + Atom a -> case a of LongOption o -> length o ShortOption _ -> 1 Command c -> length c diff --git a/docopt.cabal b/docopt.cabal --- a/docopt.cabal +++ b/docopt.cabal @@ -1,5 +1,5 @@ name: docopt -version: 0.7.0.3 +version: 0.7.0.4 synopsis: A command-line interface parser that will make you smile description: Docopt parses command-line interface usage text that adheres to a familiar syntax, and from it builds a command-line argument parser that will ensure your program is invoked correctly with the available options specified in the usage text. This allows the developer to write a usage text and get an argument parser for free. @@ -20,6 +20,8 @@ extra-source-files: README.md CHANGELOG.md +data-files: test/testcases.docopt + source-repository head type: git location: https://github.com/docopt/docopt.hs.git @@ -44,7 +46,11 @@ parsec == 3.1.*, containers - ghc-options: -Wall -fno-warn-unused-do-bind + ghc-options: -Wall + -fno-warn-unused-binds + -fno-warn-unused-do-bind + -fno-warn-unused-matches + -fno-warn-name-shadowing if impl(ghc >= 6.10) && flag(template-haskell) exposed-modules: System.Console.Docopt @@ -58,18 +64,29 @@ hs-source-dirs: ./, test main-is: LangAgnosticTests.hs + ghc-options: -Wall + -fno-warn-unused-binds + -fno-warn-unused-do-bind + -fno-warn-unused-matches + -fno-warn-name-shadowing + -fno-warn-orphans + build-depends: base == 4.*, parsec == 3.1.*, containers, docopt, - split, - ansi-terminal, - aeson, + HUnit, + split >= 0.2.2, + ansi-terminal >= 0.6, + aeson >= 0.8, bytestring == 0.10.*, template-haskell, th-lift - other-modules: System.Console.Docopt.Types, + other-modules: System.Console.Docopt.ApplicativeParsec, System.Console.Docopt.ParseUtils, + System.Console.Docopt.Types, System.Console.Docopt.UsageParse, - System.Console.Docopt.OptParse + System.Console.Docopt.OptParse, + System.Console.Docopt.Public, + Paths_docopt diff --git a/test/LangAgnosticTests.hs b/test/LangAgnosticTests.hs --- a/test/LangAgnosticTests.hs +++ b/test/LangAgnosticTests.hs @@ -1,9 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} -import Control.Monad (when, unless) +import Control.Monad ( (>=>) ) import System.Exit import System.Console.ANSI ---import System.Directory import System.Console.Docopt import System.Console.Docopt.Types @@ -15,75 +14,158 @@ import qualified Data.Map as M import Data.List.Split -import Data.Char (isSpace) import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BS +import Test.HUnit +import Paths_docopt (getDataFileName) -instance ToJSON ArgValue where - toJSON x = case x of + +instance ToJSON ArgValue where + toJSON x = case x of MultiValue vs -> toJSON $ reverse vs Value v -> toJSON v NoValue -> toJSON Null Counted n -> toJSON n Present -> toJSON True - NotPresent -> toJSON False + NotPresent -> toJSON False instance ToJSON (Map Option ArgValue) where - toJSON argmap = + toJSON argmap = let argmap' = M.mapKeys humanize argmap in toJSON argmap' coloredString :: Color -> String -> String -coloredString c str = (setSGRCode [SetColor Foreground Dull c]) ++ - str ++ - (setSGRCode [Reset]) +coloredString c str = setSGRCode [SetColor Foreground Dull c] + ++ str + ++ setSGRCode [Reset] +green, red, yellow, blue, magenta :: String -> String green = coloredString Green red = coloredString Red -yellow = coloredString Yellow +yellow = coloredString Yellow blue = coloredString Blue magenta = coloredString Magenta -forEach xs = sequence_ . (flip map) xs +main :: IO () +main = do + f <- (getDataFileName >=> readFile) "test/testcases.docopt" + tests <- testsFromDocoptSpecFile "testcases.docopt" f blacklist + counts <- runTestTT $ TestList tests + exitWith $ if failures counts > 0 + then ExitFailure 1 + else ExitSuccess -main = do - --putStrLn =<< getCurrentDirectory - testFile <- readFile "test/testcases.docopt" - --putStrLn rawTests - let notCommentLine x = (null x) || ('#' /= head x) +blacklist :: (Int, Int) -> Bool +-- Short/long option synonym equality (will fix) +blacklist (4, 1) = True +blacklist (4, 3) = True +blacklist (7, 1) = True +blacklist (8, 1) = True +blacklist (8, 2) = True +blacklist (64, 1) = True +-- Partial-option disambiguation +blacklist (4, 2) = True +blacklist (6, 3) = True +blacklist (6, 4) = True +blacklist (12, 4) = True +-- Stacked short options/flags disambiguation +blacklist (14, 1) = True +blacklist (70, 1) = True +-- Option order insensitivity +blacklist (15, 2) = True +blacklist (16, 2) = True +blacklist (17, 2) = True +blacklist (18, 2) = True +-- Argument lookup key ("" v. "arg"; should fix) +blacklist (21, 1) = True +blacklist (22, 1) = True +blacklist (22, 3) = True +blacklist (23, 1) = True +blacklist (24, 1) = True +blacklist (24, 2) = True +blacklist (25, 2) = True +blacklist (25, 3) = True +blacklist (26, 1) = True +blacklist (26, 2) = True +blacklist (27, 1) = True +blacklist (27, 2) = True +blacklist (27, 3) = True +blacklist (28, 1) = True +blacklist (28, 3) = True +blacklist (35, 1) = True +blacklist (60, 1) = True +blacklist (60, 2) = True +blacklist (61, 1) = True +blacklist (66, 1) = True +blacklist (72, 1) = True +-- Weirdly broken (argument capture; should fix) +blacklist (33, 2) = True +blacklist (33, 3) = True +blacklist (34, 3) = True +-- [options] expansion pruning (should fix) +blacklist (67, 1) = True +blacklist _ = False + +testsFromDocoptSpecFile :: String + -> String + -> ((Int, Int) -> Bool) + -> IO [Test] +testsFromDocoptSpecFile name testFile ignore = + let notCommentLine x = null x || ('#' /= head x) testFileClean = unlines $ filter notCommentLine $ lines testFile caseGroups = filter (not . null) $ splitOn "r\"\"\"" testFileClean - --putStrLn $ head caseGroups - forEach caseGroups $ \caseGroup -> do + + in + return . (:[]) . TestLabel name . test $ zip caseGroups [(1 :: Int)..] >>= \(caseGroup, icg) -> do + let [usage, rawCases] = splitOn "\"\"\"" caseGroup cases = filter (/= "\n") $ splitOn "$ " rawCases - optFormat <- case runParser pDocopt M.empty "Usage" usage of - Left e -> do - putStrLn "couldn't parse usage text" - return (Sequence [], M.empty) - Right o -> return o - putStrLn $ "Docopt:\n" ++ blue usage - putStrLn $ "Pattern:\n" ++ magenta (show optFormat) - --putStrLn $ "Cases: " ++ show cases - forEach cases $ \testcase -> do + + let (optFormat, docParseMsg) = case runParser pDocopt M.empty "Usage" usage of + Left e -> ((Sequence [], M.empty), "Couldn't parse usage text") + Right o -> (o, "") + + let groupDescLines = [ + docParseMsg, + "Docopt:", + blue usage, + "Pattern:", + magenta (show optFormat) + ] + + zip cases [(1::Int)..] >>= \(testcase, itc) -> do + let (cmdline, rawTarget_) = break (== '\n') testcase rawTarget = filter (/= '\n') rawTarget_ maybeTargetJSON = decode (BS.pack rawTarget) :: Maybe Value rawArgs = tail $ words cmdline - parsedArgs <- case getArguments optFormat rawArgs of - Left e -> do - putStrLn $ "Parse Error: " ++ (red $ show e) - return M.empty - Right a -> return a + + let (parsedArgs, argParseMsg) = case getArguments optFormat rawArgs of + Left e -> (M.empty, "Parse Error: " ++ red (show e) ++ "\n") + Right a -> (a, "") + let parsedArgsJSON = toJSON parsedArgs - testCaseSuccess = if (rawTarget == "\"user-error\"") + testCaseEquality = if rawTarget == "\"user-error\"" then M.null parsedArgs - else (maybeTargetJSON == Just parsedArgsJSON) - putStrLn $ "Case Cmd: " ++ yellow cmdline - putStrLn $ "Case Target: " ++ (if testCaseSuccess then green else magenta) rawTarget - unless testCaseSuccess $ - putStrLn $ "Failure: " ++ red (BS.unpack $ encode parsedArgsJSON) - putStrLn "" - exitSuccess + else maybeTargetJSON == Just parsedArgsJSON + blacklisted = blacklist (icg, itc) + testCaseSuccess = if blacklisted + then not testCaseEquality + else testCaseEquality + + let testDescLines = [ + "Cmd: " ++ yellow cmdline, + "Target: " ++ (if testCaseSuccess then green else magenta) rawTarget + ] + + let testMsg = unlines . filter (not . null) $ + groupDescLines + ++ testDescLines + ++ ["(Blacklisted)" | blacklisted] + ++ ["Failure: " ++ red (BS.unpack $ encode parsedArgsJSON)] + + let ti = TestCase $ testCaseSuccess @? testMsg + + return $ TestLabel ("group-" ++ show icg ++ "-case-" ++ show itc) ti diff --git a/test/testcases.docopt b/test/testcases.docopt new file mode 100644 --- /dev/null +++ b/test/testcases.docopt @@ -0,0 +1,930 @@ +r"""Usage: prog + +""" +$ prog +{} + +$ prog --xxx +"user-error" + + +r"""Usage: prog [options] + +-a All. + +""" +$ prog +{"-a": false} + +$ prog -a +{"-a": true} + +$ prog -x +"user-error" + + +r"""Usage: prog [options] + +--all All. + +""" +$ prog +{"--all": false} + +$ prog --all +{"--all": true} + +$ prog --xxx +"user-error" + + +r"""Usage: prog [options] + +-v, --verbose Verbose. + +""" +$ prog --verbose +{"--verbose": true} + +$ prog --ver +{"--verbose": true} + +$ prog -v +{"--verbose": true} + + +r"""Usage: prog [options] + +-p PATH + +""" +$ prog -p home/ +{"-p": "home/"} + +$ prog -phome/ +{"-p": "home/"} + +$ prog -p +"user-error" + + +r"""Usage: prog [options] + +--path + +""" +$ prog --path home/ +{"--path": "home/"} + +$ prog --path=home/ +{"--path": "home/"} + +$ prog --pa home/ +{"--path": "home/"} + +$ prog --pa=home/ +{"--path": "home/"} + +$ prog --path +"user-error" + + +r"""Usage: prog [options] + +-p PATH, --path= Path to files. + +""" +$ prog -proot +{"--path": "root"} + + +r"""Usage: prog [options] + + -p --path PATH Path to files. + +""" +$ prog -p root +{"--path": "root"} + +$ prog --path root +{"--path": "root"} + + +r"""Usage: prog [options] + +-p PATH Path to files [default: ./] + +""" +$ prog +{"-p": "./"} + +$ prog -phome +{"-p": "home"} + + +r"""UsAgE: prog [options] + +--path= Path to files + [dEfAuLt: /root] + +""" +$ prog +{"--path": "/root"} + +$ prog --path=home +{"--path": "home"} + + +r"""usage: prog [options] + +-a Add +-r Remote +-m Message + +""" +$ prog -a -r -m Hello +{"-a": true, + "-r": true, + "-m": "Hello"} + +$ prog -armyourass +{"-a": true, + "-r": true, + "-m": "yourass"} + +$ prog -a -r +{"-a": true, + "-r": true, + "-m": null} + + +r"""Usage: prog [options] + +--version +--verbose + +""" +$ prog --version +{"--version": true, + "--verbose": false} + +$ prog --verbose +{"--version": false, + "--verbose": true} + +$ prog --ver +"user-error" + +$ prog --verb +{"--version": false, + "--verbose": true} + + +r"""usage: prog [-a -r -m ] + +-a Add +-r Remote +-m Message + +""" +$ prog -armyourass +{"-a": true, + "-r": true, + "-m": "yourass"} + + +r"""usage: prog [-armmsg] + +-a Add +-r Remote +-m Message + +""" +$ prog -a -r -m Hello +{"-a": true, + "-r": true, + "-m": "Hello"} + + +r"""usage: prog -a -b + +-a +-b + +""" +$ prog -a -b +{"-a": true, "-b": true} + +$ prog -b -a +{"-a": true, "-b": true} + +$ prog -a +"user-error" + +$ prog +"user-error" + + +r"""usage: prog (-a -b) + +-a +-b + +""" +$ prog -a -b +{"-a": true, "-b": true} + +$ prog -b -a +{"-a": true, "-b": true} + +$ prog -a +"user-error" + +$ prog +"user-error" + + +r"""usage: prog [-a] -b + +-a +-b + +""" +$ prog -a -b +{"-a": true, "-b": true} + +$ prog -b -a +{"-a": true, "-b": true} + +$ prog -a +"user-error" + +$ prog -b +{"-a": false, "-b": true} + +$ prog +"user-error" + + +r"""usage: prog [(-a -b)] + +-a +-b + +""" +$ prog -a -b +{"-a": true, "-b": true} + +$ prog -b -a +{"-a": true, "-b": true} + +$ prog -a +"user-error" + +$ prog -b +"user-error" + +$ prog +{"-a": false, "-b": false} + + +r"""usage: prog (-a|-b) + +-a +-b + +""" +$ prog -a -b +"user-error" + +$ prog +"user-error" + +$ prog -a +{"-a": true, "-b": false} + +$ prog -b +{"-a": false, "-b": true} + + +r"""usage: prog [ -a | -b ] + +-a +-b + +""" +$ prog -a -b +"user-error" + +$ prog +{"-a": false, "-b": false} + +$ prog -a +{"-a": true, "-b": false} + +$ prog -b +{"-a": false, "-b": true} + + +r"""usage: prog + +""" +$ prog 10 +{"": "10"} + +$ prog 10 20 +"user-error" + +$ prog +"user-error" + + +r"""usage: prog [] + +""" +$ prog 10 +{"": "10"} + +$ prog 10 20 +"user-error" + +$ prog +{"": null} + + +r"""usage: prog + +""" +$ prog 10 20 40 +{"": "10", "": "20", "": "40"} + +$ prog 10 20 +"user-error" + +$ prog +"user-error" + + +r"""usage: prog [ ] + +""" +$ prog 10 20 40 +{"": "10", "": "20", "": "40"} + +$ prog 10 20 +{"": "10", "": "20", "": null} + +$ prog +"user-error" + + +r"""usage: prog [ | ] + +""" +$ prog 10 20 40 +"user-error" + +$ prog 20 40 +{"": null, "": "20", "": "40"} + +$ prog +{"": null, "": null, "": null} + + +r"""usage: prog ( --all | ) + +--all + +""" +$ prog 10 --all +{"": "10", "--all": true, "": null} + +$ prog 10 +{"": null, "--all": false, "": "10"} + +$ prog +"user-error" + + +r"""usage: prog [ ] + +""" +$ prog 10 20 +{"": ["10", "20"]} + +$ prog 10 +{"": ["10"]} + +$ prog +{"": []} + + +r"""usage: prog [( )] + +""" +$ prog 10 20 +{"": ["10", "20"]} + +$ prog 10 +"user-error" + +$ prog +{"": []} + + +r"""usage: prog NAME... + +""" +$ prog 10 20 +{"NAME": ["10", "20"]} + +$ prog 10 +{"NAME": ["10"]} + +$ prog +"user-error" + + +r"""usage: prog [NAME]... + +""" +$ prog 10 20 +{"NAME": ["10", "20"]} + +$ prog 10 +{"NAME": ["10"]} + +$ prog +{"NAME": []} + + +r"""usage: prog [NAME...] + +""" +$ prog 10 20 +{"NAME": ["10", "20"]} + +$ prog 10 +{"NAME": ["10"]} + +$ prog +{"NAME": []} + + +r"""usage: prog [NAME [NAME ...]] + +""" +$ prog 10 20 +{"NAME": ["10", "20"]} + +$ prog 10 +{"NAME": ["10"]} + +$ prog +{"NAME": []} + + +r"""usage: prog (NAME | --foo NAME) + +--foo + +""" +$ prog 10 +{"NAME": "10", "--foo": false} + +$ prog --foo 10 +{"NAME": "10", "--foo": true} + +$ prog --foo=10 +"user-error" + + +r"""usage: prog (NAME | --foo) [--bar | NAME] + +--foo +--bar + +""" +$ prog 10 +{"NAME": ["10"], "--foo": false, "--bar": false} + +$ prog 10 20 +{"NAME": ["10", "20"], "--foo": false, "--bar": false} + +$ prog --foo --bar +{"NAME": [], "--foo": true, "--bar": true} + + +r"""Naval Fate. + +Usage: + prog ship new ... + prog ship [] move [--speed=] + prog ship shoot + prog mine (set|remove) [--moored|--drifting] + prog -h | --help + prog --version + +Options: + -h --help Show this screen. + --version Show version. + --speed= Speed in knots [default: 10]. + --moored Mored (anchored) mine. + --drifting Drifting mine. + +""" +$ prog ship Guardian move 150 300 --speed=20 +{"--drifting": false, + "--help": false, + "--moored": false, + "--speed": "20", + "--version": false, + "": ["Guardian"], + "": "150", + "": "300", + "mine": false, + "move": true, + "new": false, + "remove": false, + "set": false, + "ship": true, + "shoot": false} + + +r"""usage: prog --hello + +""" +$ prog --hello +{"--hello": true} + + +r"""usage: prog [--hello=] + +""" +$ prog +{"--hello": null} + +$ prog --hello wrld +{"--hello": "wrld"} + + +r"""usage: prog [-o] + +""" +$ prog +{"-o": false} + +$ prog -o +{"-o": true} + + +r"""usage: prog [-opr] + +""" +$ prog -op +{"-o": true, "-p": true, "-r": false} + + +r"""usage: prog --aabb | --aa + +""" +$ prog --aa +{"--aabb": false, "--aa": true} + +$ prog --a +"user-error" + +# +# Counting number of flags +# + +r"""Usage: prog -v + +""" +$ prog -v +{"-v": true} + + +r"""Usage: prog [-v -v] + +""" +$ prog +{"-v": 0} + +$ prog -v +{"-v": 1} + +$ prog -vv +{"-v": 2} + + +r"""Usage: prog -v ... + +""" +$ prog +"user-error" + +$ prog -v +{"-v": 1} + +$ prog -vv +{"-v": 2} + +$ prog -vvvvvv +{"-v": 6} + + +r"""Usage: prog [-v | -vv | -vvv] + +This one is probably most readable user-friednly variant. + +""" +$ prog +{"-v": 0} + +$ prog -v +{"-v": 1} + +$ prog -vv +{"-v": 2} + +$ prog -vvvv +"user-error" + + +r"""usage: prog [--ver --ver] + +""" +$ prog --ver --ver +{"--ver": 2} + + +# +# Counting commands +# + +r"""usage: prog [go] + +""" +$ prog go +{"go": true} + + +r"""usage: prog [go go] + +""" +$ prog +{"go": 0} + +$ prog go +{"go": 1} + +$ prog go go +{"go": 2} + +$ prog go go go +"user-error" + +r"""usage: prog go... + +""" +$ prog go go go go go +{"go": 5} + +# +# Test [options] shourtcut +# + +r"""Usage: prog [options] A + + -q Be quiet + -v Be verbose. + +""" +$ prog arg +{"A": "arg", "-v": false, "-q": false} + +$ prog -v arg +{"A": "arg", "-v": true, "-q": false} + +$ prog -q arg +{"A": "arg", "-v": false, "-q": true} + +# +# Test single dash +# + +r"""usage: prog [-]""" +$ prog - +{"-": true} + +$ prog +{"-": false} + +# +# If argument is repeated, its value should always be a list +# + +r"""usage: prog [NAME [NAME ...]]""" +$ prog a b +{"NAME": ["a", "b"]} + +$ prog +{"NAME": []} + +# +# Option's argument defaults to null/None +# + +r"""usage: prog [options] + +-a Add +-m Message + +""" +$ prog -a +{"-m": null, "-a": true} + +# +# Test options without description +# + +r"""usage: prog --hello""" +$ prog --hello +{"--hello": true} + +r"""usage: prog [--hello=]""" +$ prog +{"--hello": null} + +$ prog --hello wrld +{"--hello": "wrld"} + +r"""usage: prog [-o]""" +$ prog +{"-o": false} + +$ prog -o +{"-o": true} + +r"""usage: prog [-opr]""" +$ prog -op +{"-o": true, "-p": true, "-r": false} + +r"""usage: git [-v | --verbose]""" +$ prog -v +{"-v": true, "--verbose": false} + +r"""usage: git remote [-v | --verbose]""" +$ prog remote -v +{"remote": true, "-v": true, "--verbose": false} + +# +# Test empty usage pattern +# + +r"""usage: prog""" +$ prog +{} + +r"""usage: prog + prog +""" +$ prog 1 2 +{"": "1", "": "2"} + +$ prog +{"": null, "": null} + +r"""usage: prog + prog +""" +$ prog +{"": null, "": null} + +# +# Option's argument should not capture default value from usage pattern +# + +r"""usage: prog [--file=]""" +$ prog +{"--file": null} + +r"""usage: prog [--file=] + +--file + +""" +$ prog +{"--file": null} + +r"""Usage: prog [-a ] + +-a, --address TCP address [default: localhost:6283]. + +""" +$ prog +{"--address": "localhost:6283"} + +# +# If option with argument could be repeated, +# its arguments should be accumulated into a list +# + +r"""usage: prog --long= ...""" +$ prog --long one +{"--long": ["one"]} + +$ prog --long one --long two +{"--long": ["one", "two"]} + +# +# Test multiple elements repeated at once +# + +r"""usage: prog (go --speed=)...""" +$ prog go left --speed=5 go right --speed=9 +{"go": 2, "": ["left", "right"], "--speed": ["5", "9"]} + +# +# Required options should work with option shortcut +# + +r"""usage: prog [options] -a + +-a + +""" +$ prog -a +{"-a": true} + +# +# If option could be repeated its defaults should be split into a list +# + +r"""usage: prog [-o ]... + +-o [default: x] + +""" +$ prog -o this -o that +{"-o": ["this", "that"]} + +$ prog +{"-o": ["x"]} + +r"""usage: prog [-o ]... + +-o [default: x y] + +""" +$ prog -o this +{"-o": ["this"]} + +$ prog +{"-o": ["x", "y"]} + +# +# Test stacked option's argument +# + +r"""usage: prog -pPATH + +-p PATH + +""" +$ prog -pHOME +{"-p": "HOME"} + +# +# Issue 56: Repeated mutually exclusive args give nested lists sometimes +# + +r"""Usage: foo (--xx=x|--yy=y)...""" +$ prog --xx=1 --yy=2 +{"--xx": ["1"], "--yy": ["2"]} + +# +# POSIXly correct tokenization +# + +r"""usage: prog []""" +$ prog f.txt +{"": "f.txt"} + +r"""usage: prog [--input=]...""" +$ prog --input a.txt --input=b.txt +{"--input": ["a.txt", "b.txt"]} + +# +# Issue 85: `[options]` shourtcut with multiple subcommands +# + +r"""usage: prog good [options] + prog fail [options] + +--loglevel=N + +""" +$ prog fail --loglevel 5 +{"--loglevel": "5", "fail": true, "good": false}