parse-help (empty) → 0.0
raw patch · 5 files changed
+292/−0 lines, 5 filesdep +attoparsecdep +basedep +cmdargssetup-changed
Dependencies added: attoparsec, base, cmdargs, containers, data-default, file-location, template-haskell, text, th-lift
Files
- LICENSE +25/−0
- Setup.hs +2/−0
- System/Console/ParseHelp.hs +177/−0
- parse-help.cabal +36/−0
- test/Help.hs +52/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Greg Weber. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Console/ParseHelp.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Console.ParseHelp (+ parseHelp, ParsedHelp, ParsedFlag(..)+) where++import Data.Attoparsec.Text+import Control.Applicative ((<|>), many)+import Data.Text (Text, unpack, pack)+import qualified Data.Text as T+import Language.Haskell.TH.Lift+import Prelude hiding (takeWhile)++instance Lift Text where lift = lift . unpack++data ParsedFlag = ParsedFlag {+ parsedFlagShort :: Maybe Char, + parsedFlagLong :: Maybe Text,+ parsedFlagType :: Maybe Text,+ parsedFlagDescription :: Maybe Text+ } deriving (Show)+deriveLift ''ParsedFlag++type ParsedMode = (Text, -- ^ program name+ Text, -- ^ mode name+ [ParsedFlag])+type ParsedCommonMode = (Text, [ParsedFlag]) -- no mode name+++parseHelp :: String -> Either String ParsedHelp+parseHelp s =+ case attoParser (pack s) of+ Left e -> Left e+ Right pHelp -> Right $ prepareParsedHelp pHelp++attoParser :: Text -> Either String (Maybe Text, -- ^ program description+ Maybe ParsedCommonMode,+ [ParsedMode])+attoParser input = parseOnly commandArgs input+ where+ commandArgs = do+ description <- maybeManyTill anyChar blankLine+ optional blankLines+ common <- optionMaybe commonInvocation+ optional blankLines+ modes <- many modeInvocation+ return (description, common, modes)+ where+ spaces = skipSpace+ commonInvocation = do+ -- sample [OPTIONS]+ name <- commonProgName+ optional blankLines+ spaces+ -- optional blankLines+ -- optional $ takeWhile (notInClass "\r\n") >> eol'+ optional blankLines+ optional $ string "Common flags" >> takeWhile (notInClass "-\r\n") >> eol'+ spaces+ optional blankLines+ opts <- flags+ return (name, opts)++ modeInvocation = do+ (name, mode) <- progName+ optional blankLines+ opts <- flags+ return (name, mode, opts)++ betweenChars start end = do+ _ <- char start+ r <- takeWhile1 (/= end)+ _ <- char end+ return r++ bracketed = betweenChars '[' ']'++ commonProgName = do+ spaces+ t <- takeWhile1 notSpace+ spaces+ optional $ (bracketed <|> takeWhile1 notBracketed) >> return ()+ spaces+ optional $ string "..." >> return ()+ spaces+ _ <- bracketed+ return t++ notBracketed = notInClass $ '[':whiteSpaceChars+ progName = do+ spaces+ t <- takeWhile1 notSpace+ spaces+ m <- takeWhile1 notBracketed+ spaces+ _ <- bracketed+ return (t,m)++ maybeText = fmap (\t -> if T.null t then Nothing else Just t)+ flags = many1 flag+ where+ flag = do+ spaces+ ms <- optionMaybe shortFlag+ spaces+ ml <- optionMaybe longFlag+ d <- maybeText (takeTill $ inClass "\r\n")+ case (ms, ml) of+ (Nothing, Nothing) -> fail "expected flags"+ (_, Just (long,typ)) -> return $ ParsedFlag ms (Just long) typ d+ (_, Nothing) -> return $ ParsedFlag ms Nothing Nothing d+ where+ shortFlag = do+ _ <- char '-'+ satisfy notSpace++ longFlag = do+ _ <- string "--"+ long <- takeWhile1 (notInClass $ '=':whiteSpaceChars)+ def <- optionMaybe $ char '=' >> takeWhile1 notSpace+ return (long, def)++ whiteSpaceChars = " \v\f\t\r\n"+ notSpace = notInClass whiteSpaceChars++ maybeManyTill p stop = do+ r <- manyTill p stop+ return $ if r == [] then Nothing else Just $ pack r++ blankLines = many1 blankLine >> return ()+ blankLine = eol >> eol++ eol' = eol >> return ()+ eol = endOfLine++ optional = option ()++{-+ showRest = do+ rest <- restOfLine+ error $ "rest: " ++ (show rest)+ restOfLine = manyTill anyChar eol+ -}++ optionMaybe p = option Nothing $ (fmap Just) p++type ParsedHelp = (Text, Maybe Text, [ParsedFlag], [(Text, [ParsedFlag])])+prepareParsedHelp :: (Maybe Text, Maybe ParsedCommonMode, [ParsedMode])+ -> ParsedHelp+prepareParsedHelp (_, Nothing, []) = error "No command flags found"+prepareParsedHelp (description, mCommon, parsedModes) =+ let (name, common) = case mCommon of+ Nothing -> (fst3 $ head parsedModes, defaultCommonFlags)+ Just (commonName, flags) -> (commonName, flags)+ in let modes = map (checkMode name) parsedModes+ in (name, description, common, modes)+ where+ fst3 (x,_,_) = x+ checkMode :: Text -> (Text, Text, [ParsedFlag]) -> (Text, [ParsedFlag])+ checkMode commonProgName (progName, mode, flags) =+ if progName /= commonProgName then error $ "inconsistent program name: expected "++unpack commonProgName++", got "++unpack progName+ else (mode, flags)++ defaultCommonFlags = [+ ParsedFlag (Just '?') (Just $ pack "help") Nothing (Just $ pack "Display help message")+ , ParsedFlag (Just 'V') (Just $ pack "version") Nothing (Just $ pack "Print version information")+ ]++ -- makeCmdArgs $ prepareParsedHelp parseHelp+++-- check indent level?+{-parseIndent :: Parser Int -}+{-parseIndent =-}+ {-sum `fmap` many ((char ' ' >> return 1) <|> (char '\t' >> return 4)) -}+
+ parse-help.cabal view
@@ -0,0 +1,36 @@+name: parse-help+version: 0.0+license: BSD3+author: Greg Weber <greg@gregweber.info>+maintainer: Greg Weber <greg@gregweber.info>+synopsis: generate command line arguments from a --help output+description: see http://github.com/gregwebs/cmdargs-help+category: Console+license-file: LICENSE++stability: Stable+cabal-version: >= 1.8+build-type: Simple+homepage: http://github.com/gregwebs/cmdargs-help++library+ build-depends: base == 0.4.*+ , containers+ , data-default+ , attoparsec == 0.10.*+ , th-lift+ , text+ , file-location+ , template-haskell+ exposed-modules: System.Console.ParseHelp+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: Help.hs+ hs-source-dirs: ., test+ build-depends: cmdargs++source-repository head+ type: git+ location: http://github.com/gregwebs/cmdargs-help
+ test/Help.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell, OverloadedStrings, DeriveDataTypeable #-}+import System.Console.CmdArgs.FromHelp+import System.Console.CmdArgs hiding (cmdArgsHelp)+import System.Environment (getArgs)++{-printHelp :: Annotate Ann -> IO ()-}+{-printHelp a = print =<< (cmdArgs_ a :: IO FromHelpArgs)-}++{-+main :: IO ()+main = print =<< processArgs [cmdArgsHelp|+-}++mkCmdArgs [fromHelp|+ The sample program++sample [COMMAND] ... [OPTIONS]++Common flags+ -h --help Display help message+ -V --version Print version information+ -w --whom=GUY++sample hello [OPTIONS]++ -t --top Top of the Morning to you!++sample goodbye [OPTIONS]++ -s --sianara+ -c --ciao+|]++main :: IO ()+main = do+ print defaultHello+ print defaultGoodbye++ args <- getArgs+ if "--help" `elem` args || "-?" `elem` args+ -- helpContents and default.. are references generated by mkCmdArgs+ then putStrLn helpContents+ else print =<< cmdArgs (modes [defaultHello, defaultGoodbye])++{-+ dist/build/test/test goodbye -s sucker++ Hello {top = "", whom = ""}+ Goodbye {whom = "", sianara = "", ciao = ""}+ Goodbye {whom = "", sianara = "sucker", ciao = ""}+-}