diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Console/ParseHelp.hs b/System/Console/ParseHelp.hs new file mode 100644 --- /dev/null +++ b/System/Console/ParseHelp.hs @@ -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)) -} + diff --git a/parse-help.cabal b/parse-help.cabal new file mode 100644 --- /dev/null +++ b/parse-help.cabal @@ -0,0 +1,36 @@ +name: parse-help +version: 0.0 +license: BSD3 +author: Greg Weber +maintainer: Greg Weber +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 diff --git a/test/Help.hs b/test/Help.hs new file mode 100644 --- /dev/null +++ b/test/Help.hs @@ -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 = ""} +-}