docopt (empty) → 0.6.0
raw patch · 11 files changed
+1065/−0 lines, 11 filesdep +aesondep +ansi-terminaldep +basesetup-changed
Dependencies added: aeson, ansi-terminal, base, bytestring, containers, docopt, parsec, split
Files
- LICENSE.txt +20/−0
- Setup.hs +2/−0
- System/Console/Docopt.hs +7/−0
- System/Console/Docopt/ApplicativeParsec.hs +12/−0
- System/Console/Docopt/OptParse.hs +235/−0
- System/Console/Docopt/ParseUtils.hs +95/−0
- System/Console/Docopt/Public.hs +140/−0
- System/Console/Docopt/Types.hs +100/−0
- System/Console/Docopt/UsageParse.hs +315/−0
- docopt.cabal +50/−0
- test/LangAgnosticTests.hs +89/−0
+ LICENSE.txt view
@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright (c) 2013 Ryan Artecona++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Console/Docopt.hs view
@@ -0,0 +1,7 @@+module System.Console.Docopt + ( + module System.Console.Docopt.Public,+ )+ where++import System.Console.Docopt.Public
+ System/Console/Docopt/ApplicativeParsec.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_HADDOCK hide #-}++module System.Console.Docopt.ApplicativeParsec+ (+ module Control.Applicative+ , module Text.ParserCombinators.Parsec+ ) where++import Control.Applicative hiding (optional, (<|>))+import Control.Monad (MonadPlus(..), ap)+import Text.ParserCombinators.Parsec hiding (many)
+ System/Console/Docopt/OptParse.hs view
@@ -0,0 +1,235 @@+module System.Console.Docopt.OptParse + where++import Control.Monad (unless)++import qualified Data.Map as M+import Data.List (intercalate, nub, (\\))++import System.Console.Docopt.ParseUtils+import System.Console.Docopt.Types+++-- | The meat and potatoes.+buildOptParser :: String ->+ -- ^ an obscure delimiter with which to intercalate the args list+ OptFormat -> + -- ^ the expected form of the options + CharParser OptParserState ()+ -- ^ a CharParser with which a ParsedArguments (k,v) list can be built+buildOptParser delim fmt@(pattern, infomap) = + + let -- Helpers+ argDelim = (try $ string delim) <?> "space between arguments"+ + makeParser p = buildOptParser delim (p, infomap)+ + argDelimIfNotInShortOptStack = do + st <- getState + if not $ inShortOptStack st+ then optional argDelim+ else return ()++ updateOptWith :: (Option -> OptionInfo -> String -> Arguments -> Arguments) ->+ Option ->+ String ->+ CharParser OptParserState ()+ updateOptWith updateFn opt val = do+ st <- getState+ let optInfo = (optInfoMap st) M.! opt+ updateState $ updateParsedArgs $ updateFn opt optInfo val++ updateSt_saveOccurrence opt val = updateOptWith saveOccurrence opt val+ updateSt_assertPresent opt = updateOptWith (\opt info _ -> assertPresent opt info) opt ""++ updateSt_inShortOptStack = updateState . updateInShortOptStack+ + in case pattern of+ (Sequence pats) ->+ assertTopConsumesAll $ foldl (andThen) (return ()) ps + where assertTopConsumesAll p = do+ st <- getState+ if inTopLevelSequence st+ then do + updateState $ \st -> st {inTopLevelSequence = False}+ p <* eof+ else p + inner_pats = (\pat -> (pat, infomap)) `map` pats+ ps = (buildOptParser delim) `map` inner_pats+ andThen = \p1 p2 -> do + p1+ argDelimIfNotInShortOptStack+ p2+ (OneOf pats) ->+ choice $ (try . makeParser) `map` pats+ (Unordered pats) -> case pats of+ pat:[] -> makeParser pat+ _ -> choice $ (parseThisThenRest pats) `map` pats+ where parseThisThenRest list pat = try $ do+ makeParser pat+ let rest = list \\ [pat]+ argDelimIfNotInShortOptStack+ makeParser $ Unordered rest+ (Optional pat) ->+ case pat of + Unordered ps -> case ps of + p:[] -> makeParser $ Optional p+ _ -> optional $ choice $ (parseThisThenRest ps) `map` ps+ where parseThisThenRest list pat = try $ do+ makeParser pat+ let rest = list \\ [pat]+ argDelimIfNotInShortOptStack+ makeParser $ Optional $ Unordered rest+ _ -> optional $ try $ makeParser pat + (Repeated pat) -> do+ case pat of + (Optional p) -> (try $ makeParser p) `sepBy` argDelimIfNotInShortOptStack+ _ -> (try $ makeParser pat) `sepBy1` argDelimIfNotInShortOptStack+ return ()+ (Atom pat) -> case pat of + o@(ShortOption c) ->+ do st <- getState+ if inShortOptStack st then return () else char '-' >> return ()+ char c+ updateState $ updateInShortOptStack True+ val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap + then try $ do + optional $ string "=" <|> argDelim+ updateState $ updateInShortOptStack False+ manyTill1 anyChar (lookAhead_ argDelim <|> eof)+ else do+ stillInShortStack <- isNotFollowedBy argDelim+ unless stillInShortStack $ + updateState $ updateInShortOptStack False + return ""+ updateState $ withEachSynonym o $+ \pa syn info -> saveOccurrence syn info val pa+ <?> humanize o+ o@(LongOption name) ->+ do string "--"+ string name+ val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap + then do + string "=" <|> argDelim+ --many (notFollowedBy (string delim) >> anyChar)+ manyTill1 anyChar (lookAhead_ argDelim <|> eof)+ else return ""+ updateState $ withEachSynonym o $+ \pa syn info -> saveOccurrence syn info val pa+ updateState $ updateInShortOptStack False+ <?> humanize o+ o@(AnyOption) ->+ let synlists = nub . map synonyms $ M.elems infomap+ --oneOf syns = OneOf (map Atom syns)+ --synparsers = oneOf `map` synlists+ oneOfSyns = map (\ss -> OneOf (map Atom ss)) synlists+ unorderedSynParser = buildOptParser delim (Unordered oneOfSyns, infomap)+ in unorderedSynParser + <?> humanize o+ o@(Argument name) ->+ do val <- try $ many1 (notFollowedBy argDelim >> anyChar)+ updateSt_saveOccurrence o val+ updateSt_inShortOptStack False+ <?> humanize o+ o@(Command name) ->+ do string name+ updateSt_assertPresent o+ updateSt_inShortOptStack False+ <?> humanize o+++-- ** Helpers+++-- | converts a parser to return its user-state+-- instead of its return value+returnState :: CharParser u a -> CharParser u u+returnState p = p >> getState++updateInShortOptStack :: Bool -> OptParserState -> OptParserState+updateInShortOptStack b ops = ops {inShortOptStack = b}++updateParsedArgs :: (Arguments -> Arguments) -> OptParserState -> OptParserState+updateParsedArgs f st = st {parsedArgs = f $ parsedArgs st}++saveOccurrence :: Option -> OptionInfo -> String -> Arguments -> Arguments+saveOccurrence opt info newval argmap = M.alter updateCurrentVal opt argmap+ where updateCurrentVal m_oldval = case m_oldval of+ Nothing -> (newval `updateFrom`) =<< (optInitialValue info opt)+ Just oldval -> newval `updateFrom` oldval + updateFrom newval oldval = Just $ case oldval of+ MultiValue vs -> MultiValue $ newval : vs+ Value v -> Value newval+ NoValue -> Value newval+ Counted n -> Counted (n+1)+ Present -> Present+ NotPresent -> Present++assertPresent :: Option -> OptionInfo -> Arguments -> Arguments+assertPresent opt info argmap = saveOccurrence opt info "" argmap++withEachSynonym :: Option -> + (Arguments -> Option -> OptionInfo -> Arguments) -> + OptParserState -> + OptParserState+withEachSynonym opt savefn st = + let infomap = optInfoMap st+ args = parsedArgs st+ syns = synonyms $ M.findWithDefault (fromSynList []) opt infomap+ -- give the savefn each opt's info, as well+ foldsavefn = \args opt -> + let info = M.findWithDefault (fromSynList []) opt infomap+ in savefn args opt info + in st {parsedArgs = foldl foldsavefn args syns}+++optInitialValue :: OptionInfo -> Option -> Maybe ArgValue+optInitialValue info opt = + let repeatable = isRepeated info + in case opt of+ Command name -> Just $ if repeatable then Counted 0 else NotPresent+ Argument name -> Just $ if repeatable then MultiValue [] else NoValue+ AnyOption -> Nothing -- no storable value for [options] shortcut+ _ -> case expectsVal info of + True -> Just $ if repeatable then MultiValue [] else NoValue+ False -> Just $ if repeatable then Counted 0 else NotPresent++optDefaultValue :: OptionInfo -> Option -> Maybe ArgValue+optDefaultValue info opt = + let repeatable = isRepeated info+ in case opt of + Command name -> Just $ if repeatable then Counted 0 else NotPresent+ Argument name -> Just $ if repeatable then MultiValue [] else NoValue+ AnyOption -> Nothing -- no storable value for [options] shortcut+ _ -> case expectsVal info of + True -> case defaultVal info of+ Just dval -> Just $ if repeatable + then MultiValue $ reverse $ words dval+ else Value dval+ Nothing -> Just $ if repeatable then MultiValue [] else NoValue+ False -> Just $ if repeatable then Counted 0 else NotPresent+++getArguments :: OptFormat -> [String] -> Either ParseError Arguments+getArguments optfmt argv = + let (pattern, infomap) = optfmt++ -- delimiter used to flatten argv to parsable String+ delim = "«»" + argvString = delim `intercalate` argv++ p = parsedArgs <$> (returnState $ buildOptParser delim optfmt)+ + patAtoms = atoms pattern+ infoKeys = (\\ [AnyOption]) $ M.keys infomap+ allAtoms = nub $ patAtoms ++ infoKeys+ defaultArgVals = foldl f M.empty allAtoms+ where f argmap atom = M.alter (\_ -> optDefaultValue (infomap M.! atom) atom) atom argmap++ initialState = (fromOptInfoMap infomap)++ e_parsedArgs = runParser p initialState "argv" argvString++ fillMissingDefaults = \pargs -> M.union pargs defaultArgVals++ in fillMissingDefaults <$> e_parsedArgs
+ System/Console/Docopt/ParseUtils.hs view
@@ -0,0 +1,95 @@+module System.Console.Docopt.ParseUtils+ (+ module System.Console.Docopt.ParseUtils,+ module System.Console.Docopt.ApplicativeParsec,+ module Data.Char,+ )+ where++import System.Console.Docopt.ApplicativeParsec++import Data.Map (Map)+import qualified Data.Map as M++import Data.Char (isSpace, toUpper, toLower)++-- * Constants++lowers = ['a'..'z']+uppers = ['A'..'Z']+letters = lowers++uppers+numerics = ['0'..'9']++"-_"+specialChars = " :/"+alphanumerics = letters++numerics+alphanumSpecial = alphanumerics ++ specialChars+++-- * Basic Parsers++caseInsensitive :: String -> CharParser u String+caseInsensitive = sequence . (map (\c -> (char $ toLower c) <|> (char $ toUpper c)))++lookAhead_ :: CharParser u a -> CharParser u ()+lookAhead_ p = do lookAhead p+ return ()++isNotFollowedBy :: Show a => CharParser u a -> CharParser u Bool+isNotFollowedBy p = option False (notFollowedBy p >> return True)++isInlineSpace :: Char -> Bool+isInlineSpace c = not (c `elem` "\n\r") + && (isSpace c)++inlineSpace :: CharParser u Char+inlineSpace = satisfy isInlineSpace+ <?> "inline-space"++-- | like `spaces`, except does not match newlines+inlineSpaces :: CharParser u ()+inlineSpaces = skipMany (satisfy isInlineSpace)+ <?> "inline-spaces"++inlineSpaces1 :: CharParser u ()+inlineSpaces1 = skipMany1 (satisfy isInlineSpace)+ <?> "1+ inline-spaces"++spaces1 :: CharParser u ()+spaces1 = skipMany1 (satisfy isSpace)+ <?> ">=1 spaces"++endline = inlineSpaces >> newline+optionalEndline = inlineSpaces >> (optional newline)++pipe = char '|' <?> "'|'"++ellipsis :: CharParser u String+ellipsis = inlineSpaces >> string "..."+ <?> "'...'"+++manyTill1 p end = do+ first <- p + rest <- manyTill p end+ return $ first : rest++-- |@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) + `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)+ manyP = p `sepBy` inlineSpaces1+++-- | Data.Map utils+alterAllWithKey :: Ord k => (k -> Maybe a -> Maybe a) -> [k] -> Map k a -> Map k a+alterAllWithKey f ks m = foldl (\m' k -> M.alter (f k) k m') m ks
+ System/Console/Docopt/Public.hs view
@@ -0,0 +1,140 @@+module System.Console.Docopt.Public + (+ -- everything locally declared+ module System.Console.Docopt.Public,++ -- public types+ Option(),+ Arguments(),+ )+ where++import System.Environment (getArgs)+import System.Exit++import Data.Map as M hiding (null)++import Control.Applicative++import System.Console.Docopt.ParseUtils+import System.Console.Docopt.Types+import System.Console.Docopt.UsageParse (pDocopt)+import System.Console.Docopt.OptParse (getArguments)+++-- * Public API++-- ** Main option parsing entry points++optionsWithUsage :: String -> [String] -> IO Arguments+optionsWithUsage usage rawArgs = + case runParser pDocopt M.empty "Usage" usage of+ Left err -> do putStrLn usage+ exitFailure+ Right fmt -> case getArguments fmt rawArgs of+ Left err -> do putStrLn usage+ exitFailure+ Right parsedArgs -> return parsedArgs++optionsWithUsageDebug :: String -> [String] -> IO Arguments+optionsWithUsageDebug usage rawArgs =+ case runParser pDocopt M.empty "Usage" usage of+ Left err -> fail $ show err+ Right fmt -> case getArguments fmt rawArgs of+ Left err -> fail $ show err+ Right parsedArgs -> return parsedArgs++optionsWithUsageFile :: FilePath -> IO Arguments+optionsWithUsageFile path = do usageStr <- readFile path+ rawArgs <- getArgs+ optionsWithUsage usageStr rawArgs++optionsWithUsageFileDebug :: FilePath -> IO Arguments+optionsWithUsageFileDebug path = do usageStr <- readFile path+ rawArgs <- getArgs+ optionsWithUsageDebug usageStr rawArgs++-- ** Option lookup methods++isPresent :: Arguments -> Option -> Bool+isPresent args opt = + case opt `M.lookup` args of+ Nothing -> False+ Just val -> case val of+ NoValue -> False+ NotPresent -> False+ _ -> True++isPresentM :: Monad m => Arguments -> Option -> m Bool+isPresentM args o = return $ isPresent args o++notPresent :: Arguments -> Option -> Bool+notPresent args o = not $ isPresent args o++notPresentM :: Monad m => Arguments -> Option -> m Bool+notPresentM args o = return $ not $ isPresent args o++getArg :: Monad m => Arguments -> Option -> m String+getArg args opt = + let failure = fail $ "no argument given: " ++ show opt+ in case opt `M.lookup` args of+ Nothing -> failure+ Just val -> case val of+ MultiValue (v:vs) -> return v+ Value v -> return v+ _ -> failure ++getFirstArg :: Monad m => Arguments -> Option -> m String+getFirstArg args opt = + let failure = fail $ "no argument given: " ++ show opt+ in case opt `M.lookup` args of+ Nothing -> failure+ Just val -> case val of+ MultiValue vs -> if null vs then failure else return $ last vs+ Value v -> return v+ _ -> failure +++getArgWithDefault :: Arguments -> String -> Option -> String+getArgWithDefault args def opt = + case args `getArg` opt of+ Just val -> val+ Nothing -> def++getAllArgs :: Arguments -> Option -> [String]+getAllArgs args opt = + case opt `M.lookup` args of+ Nothing -> []+ Just val -> case val of+ MultiValue vs -> reverse vs+ Value v -> [v] + _ -> []++getAllArgsM :: Monad m => Arguments -> Option -> m [String]+getAllArgsM o e = return $ getAllArgs o e++getArgCount :: Arguments -> Option -> Int+getArgCount args opt = + case opt `M.lookup` args of+ Nothing -> 0+ Just val -> case val of+ Counted i -> i+ MultiValue vs -> length vs+ Value _ -> 1+ Present -> 1+ _ -> 0+++-- ** Public Option constructor functions++command :: String -> Option+command s = Command s++argument :: String -> Option+argument s = Argument s++shortOption :: Char -> Option+shortOption c = ShortOption c++longOption :: String -> Option+longOption s = LongOption s
+ System/Console/Docopt/Types.hs view
@@ -0,0 +1,100 @@+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++type Name = String++data Pattern a = Sequence [Pattern a]+ | OneOf [Pattern a]+ | Unordered [Pattern a]+ | Optional (Pattern a)+ | Repeated (Pattern a)+ | Atom a+ 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 (Optional p) = atoms p+atoms (Repeated p) = atoms p+atoms (Atom a) = [a]++data Option = LongOption Name+ | ShortOption Char+ | Command Name+ | Argument Name+ | AnyOption+ deriving (Show, Eq, Ord)++type OptPattern = Pattern Option++humanize :: Option -> String+humanize opt = case opt of+ Command name -> name+ Argument name -> name+ LongOption name -> "--"++name+ ShortOption c -> ['-',c]+ AnyOption -> "[options]"++-- | Used when parsing through the available option descriptions.+-- Holds a list of synonymous options, Maybe a default value (if specified),+-- an expectsVal :: Bool that indicates whether this option is a flag (--flag) +-- or an option that needs an argument (--opt=arg), and isRepeated :: Bool +-- that indicates whether this option is always single or needs to be accumulated+data OptionInfo = OptionInfo + { synonyms :: [Option]+ , defaultVal :: Maybe String+ , expectsVal :: Bool + , isRepeated :: Bool+ } deriving (Show, Eq)++fromSynList :: [Option] -> OptionInfo+fromSynList opts = OptionInfo { synonyms = opts+ , defaultVal = Nothing+ , expectsVal = False+ , isRepeated = False }++-- | Maps each available option to a OptionInfo entry+-- (each synonymous option gets its own separate entry, for easy lookup)+type OptInfoMap = Map Option OptionInfo++-- | Contains all the relevant information parsed out of a usage string.+-- Used to build the actual command-line arg parser.+type OptFormat = (OptPattern, OptInfoMap)++-- | +data OptParserState = OptParserState + { optInfoMap :: OptInfoMap+ , parsedArgs :: Arguments+ , inShortOptStack :: Bool+ , inTopLevelSequence :: Bool+ } deriving (Show)++fromOptInfoMap :: OptInfoMap -> OptParserState+fromOptInfoMap m = OptParserState { optInfoMap = m+ , parsedArgs = M.empty+ , inShortOptStack = False+ , inTopLevelSequence = True }+++data ArgValue = MultiValue [String]+ | Value String+ | NoValue+ | Counted Int+ | Present+ | NotPresent+ deriving (Show, Eq, Ord)++-- | Maps each Option to all of the valued parsed from the command line+-- (in order of last to first, if multiple values encountered)+type Arguments = Map Option ArgValue+
+ System/Console/Docopt/UsageParse.hs view
@@ -0,0 +1,315 @@+module System.Console.Docopt.UsageParse + where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Ord (comparing)+import GHC.Exts (Down(..))+import Data.List (nub, sortBy, maximumBy)++import System.Console.Docopt.ParseUtils+import System.Console.Docopt.Types++-- * Helpers++-- | 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+flatten (OneOf (x:[])) = x+flatten (Unordered (x:[])) = x+flatten x = x++flatSequence = flatten . Sequence+flatOneOf = flatten . OneOf+++-- * Pattern Parsers ++pLine :: CharParser OptInfoMap OptPattern+pLine = flatten . OneOf <$> pSeq `sepBy1` (inlineSpaces >> pipe)+ where pSeq = Sequence <$> (pExp `sepEndBy` inlineSpaces1)++pExpSeq :: CharParser OptInfoMap OptPattern+pExpSeq = flatten . Sequence <$> (pExp `sepEndBy1` inlineSpaces1)++pOptGroup :: CharParser OptInfoMap [OptPattern]+pOptGroup = pGroup '[' pExpSeq ']'++pReqGroup :: CharParser OptInfoMap [OptPattern]+pReqGroup = pGroup '(' pExpSeq ')'++saveOptionsExpectVal :: (a -> Option) -> [(a, Bool)] -> CharParser OptInfoMap ()+saveOptionsExpectVal t pairs = do+ 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)}+ Nothing -> (fromSynList [opt]) {expectsVal = optExpectsVal}+++pShortOption :: CharParser OptInfoMap (Char, Bool)+pShortOption = try $ do char '-' + ch <- letter + expectsVal <- pOptionArgument+ return (ch, expectsVal)++pStackedShortOption :: CharParser OptInfoMap OptPattern+pStackedShortOption = try $ do + char '-'+ chars <- many1 $ letter+ lastExpectsVal <- pOptionArgument+ let (firstChars, lastChar) = (init chars, last chars)+ firstPairs = map (\x -> (x,False)) firstChars+ lastPair = (lastChar, lastExpectsVal)+ saveOptionsExpectVal ShortOption (firstPairs ++ [lastPair])+ case length chars of+ 0 -> fail ""+ 1 -> return $ Atom . ShortOption $ head chars+ _ -> return $ Unordered $ map (Atom . ShortOption) chars++pLongOption :: CharParser OptInfoMap (Name, Bool)+pLongOption = try $ do + string "--" + name <- many1 $ oneOf alphanumerics+ expectsVal <- pOptionArgument+ --let expectsVal = False+ return (name, expectsVal)++pAnyOption :: CharParser OptInfoMap String+pAnyOption = try (string "options")++pOptionArgument :: CharParser OptInfoMap Bool -- True if one is encountered, else False+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) + where bracketStyle = do+ open <- char '<' + name <- many $ oneOf alphanumSpecial+ close <- char '>'+ return $ [open]++name++[close]+ upperStyle = do + first <- oneOf uppers+ rest <- many $ oneOf $ uppers ++ numerics+ return $ first:rest++pCommand :: CharParser OptInfoMap String+pCommand = many1 (oneOf alphanumerics)++-- '<arg>...' make an OptPattern Repeated if followed by ellipsis+repeatable :: CharParser OptInfoMap OptPattern -> CharParser OptInfoMap OptPattern+repeatable p = do + expct <- p+ 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)+ <|> Optional . flatten . OneOf <$> pOptGroup+ <|> return (Atom AnyOption) <* pAnyOption+ <|> pStackedShortOption+ <|> do (name, expectsVal) <- pLongOption+ saveOptionsExpectVal LongOption [(name, expectsVal)]+ return $ Atom $ LongOption name+ <|> Atom . Argument <$> pArgument+ <|> Atom . Command <$> pCommand+++-- * Usage Pattern Parsers++pUsageHeader :: CharParser OptInfoMap String+pUsageHeader = caseInsensitive "Usage:"++-- | Ignores leading spaces and first word, then parses+-- the rest of the usage line+pUsageLine :: CharParser OptInfoMap OptPattern+pUsageLine = + try $ do+ inlineSpaces + many1 (satisfy (not . isSpace)) -- prog name+ pLine++pUsagePatterns :: CharParser OptInfoMap OptPattern+pUsagePatterns = do+ many (notFollowedBy pUsageHeader >> anyChar)+ pUsageHeader+ optionalEndline+ usageLines <- (pUsageLine `sepEndBy` endline)+ return $ flatten . OneOf $ usageLines++-- * Option Synonyms & Defaults Parsers++-- | Succeeds only on the first line of an option explanation+-- (one whose first non-space character is '-')+begOptionLine :: CharParser OptInfoMap String+begOptionLine = inlineSpaces >> lookAhead (char '-') >> return "-"++pOptSynonyms :: CharParser OptInfoMap ([Option], Bool)+pOptSynonyms = do inlineSpaces + pairs <- p `sepEndBy1` (optional (char ',') >> inlineSpace)+ let options = map fst pairs+ expectsVal = or $ map snd pairs+ return (options, expectsVal)+ where p = (\(c, ev) -> (ShortOption c, ev)) <$> pShortOption+ <|> (\(s, ev) -> (LongOption s, ev)) <$> pLongOption++pDefaultTag :: CharParser OptInfoMap String+pDefaultTag = do+ caseInsensitive "[default:"+ inlineSpaces+ def <- many (noneOf "]")+ char ']'+ return def++pOptDefault :: CharParser OptInfoMap (Maybe String)+pOptDefault = do+ skipUntil (pDefaultTag <|> (newline >> begOptionLine))+ maybeDefault <- optionMaybe pDefaultTag+ return maybeDefault++pOptDescription :: CharParser OptInfoMap ()+pOptDescription = try $ do+ (syns, expectsVal) <- pOptSynonyms+ def <- pOptDefault+ skipUntil (newline >> begOptionLine)+ updateState $ \infomap -> + let optinfo = (fromSynList syns) {defaultVal = def, expectsVal = expectsVal}+ saveOptInfo infomap expct = M.insert expct optinfo infomap+ in foldl saveOptInfo infomap syns + return ()++pOptDescriptions :: CharParser OptInfoMap OptInfoMap+pOptDescriptions = do+ skipUntil (newline >> begOptionLine)+ optional newline+ optional $ pOptDescription `sepEndBy` endline+ getState+++-- | Main usage parser: parses all of the usage lines into an Exception,+-- 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 + (Just info) -> Just $ info {isRepeated = canRepeat pat el}+ (Nothing) -> Just $ (fromSynList []) {isRepeated = canRepeat pat el}+ optInfoMap' = alterAllWithKey (saveCanRepeat optPattern') (atoms optPattern') optInfoMap+ return (optPattern', optInfoMap')+++-- ** Pattern transformation & analysis++expectSynonyms :: OptInfoMap -> OptPattern -> OptPattern+expectSynonyms oim (Sequence exs) = Sequence $ map (expectSynonyms oim) exs+expectSynonyms oim (OneOf exs) = OneOf $ map (expectSynonyms oim) exs+expectSynonyms oim (Unordered exs) = Unordered $ map (expectSynonyms oim) exs+expectSynonyms oim (Optional ex) = Optional $ expectSynonyms oim ex+expectSynonyms oim (Repeated ex) = Repeated $ expectSynonyms oim ex+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) -> + case synonyms <$> e `M.lookup` oim of+ Just syns -> flatten . OneOf $ map Atom syns+ Nothing -> a+ 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 = + case pat of+ (Sequence ps) -> canRepeatInside ps || (atomicOccurrences ps > 1)+ (OneOf ps) -> foldl (||) False $ map ((flip canRepeat) target) ps+ (Unordered ps) -> canRepeatInside ps || (atomicOccurrences ps > 1)+ (Optional p) -> canRepeat p target+ (Repeated p) -> target `elem` (atoms pat)+ (Atom a) -> False+ where canRepeatInside ps = foldl (||) False $ map ((flip canRepeat) target) ps + atomicOccurrences ps = length $ filter (== target) $ atoms $ Sequence ps+++-- | Compare on specificity of parsers built from optA and optB,+-- so we can be sure the parser tries the most-specific first, where possible.+-- E.g.+-- LongOption "option" > ShortOption 'o' == True+-- Command "cmd" > Argument "arg" == True+compareOptSpecificity :: Option -> Option -> Ordering+compareOptSpecificity optA optB = case optA of + LongOption a -> case optB of+ LongOption b -> comparingFirst length a b+ _ -> GT+ ShortOption a -> case optB of+ LongOption b -> LT+ ShortOption b -> compare a b+ _ -> GT+ Command a -> case optB of + LongOption b -> LT+ ShortOption b -> LT+ Command b -> comparingFirst length a b+ _ -> GT+ Argument a -> case optB of + AnyOption -> GT+ Argument b -> comparingFirst length a b+ _ -> LT+ AnyOption -> case optB of + AnyOption -> EQ+ _ -> LT+ where + comparingFirst :: (Ord a, Ord b) => (a -> b) -> a -> a -> Ordering+ 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. +eagerSort :: OptPattern -> OptPattern+eagerSort pat = + case pat of+ Sequence ps -> Sequence $ map eagerSort ps+ OneOf ps -> OneOf $ map eagerSort+ . sortBy (comparing $ Down . maxLength) + . sortBy (comparing representativeAtom)+ $ ps+ Unordered ps -> Unordered $ map eagerSort ps+ Optional p -> Optional $ eagerSort p+ Repeated p -> Repeated $ eagerSort p + a@(Atom _) -> a+ where+ representativeAtom :: OptPattern -> Option+ representativeAtom p = case p of+ Sequence ps -> if null ps then AnyOption else representativeAtom $ head ps+ OneOf ps -> maximumBy compareOptSpecificity . map representativeAtom $ ps+ Unordered ps -> maximumBy compareOptSpecificity . map representativeAtom $ ps+ Optional p -> representativeAtom p+ Repeated p -> representativeAtom p+ Atom a -> a+ maxLength :: OptPattern -> Int+ maxLength p = case p of+ Sequence ps -> sum $ map maxLength ps+ OneOf ps -> maximum $ map maxLength ps+ Unordered ps -> sum $ map maxLength ps+ Optional p -> maxLength p+ Repeated p -> maxLength p+ Atom a -> case a of + LongOption o -> length o+ ShortOption _ -> 1+ Command c -> length c+ Argument a -> length a+ AnyOption -> 0
+ docopt.cabal view
@@ -0,0 +1,50 @@+name: docopt+version: 0.6.0+synopsis: A command-line interface description language and 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.++license: MIT+license-file: LICENSE.txt+author: Ryan Artecona+maintainer: ryanartecona@gmail.com+copyright: (c) 2013 Ryan Artecona ++stability: Experimental+category: Console++build-type: Simple+cabal-version: >=1.8+++library+ exposed-modules: System.Console.Docopt+ + 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.Public++ build-depends: base == 4.*,+ parsec == 3.1.*,+ containers++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: ./, test+ main-is: LangAgnosticTests.hs++ build-depends: base == 4.*,+ parsec == 3.1.*,+ containers,+ docopt,+ split,+ ansi-terminal,+ aeson,+ bytestring == 0.10.*++ other-modules: System.Console.Docopt.Types,+ System.Console.Docopt.ParseUtils,+ System.Console.Docopt.UsageParse,+ System.Console.Docopt.OptParse
+ test/LangAgnosticTests.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances #-}++import Control.Monad (when, unless)+import System.Exit+import System.Console.ANSI+--import System.Directory++import System.Console.Docopt+import System.Console.Docopt.Types+import System.Console.Docopt.ParseUtils+import System.Console.Docopt.UsageParse (pDocopt)+import System.Console.Docopt.OptParse (getArguments)++import Data.Map (Map)+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+++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 ++instance ToJSON (Map Option ArgValue) where+ 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])++green = coloredString Green+red = coloredString Red+yellow = coloredString Yellow +blue = coloredString Blue+magenta = coloredString Magenta++forEach xs = sequence_ . (flip map) xs+++main = do + --putStrLn =<< getCurrentDirectory+ testFile <- readFile "test/testcases.docopt"+ --putStrLn rawTests+ 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+ 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 (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 parsedArgsJSON = toJSON parsedArgs+ testCaseSuccess = 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