diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs --- a/Options/Applicative/Builder.hs +++ b/Options/Applicative/Builder.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module Options.Applicative.Builder ( -- * Parser builders -- @@ -71,7 +70,6 @@ import Control.Category import Control.Monad import Data.Lens.Common -import Data.Lens.Template import Options.Applicative.Common import Options.Applicative.Types @@ -88,10 +86,18 @@ data CommandFields a = CommandFields { _cmdCommands :: [(String, ParserInfo a)] } -$( makeLenses [ ''OptionFields - , ''FlagFields - , ''CommandFields ] ) +optNames :: Lens (OptionFields a) [OptName] +optNames = lens _optNames $ \x o -> o { _optNames = x } +optReader :: Lens (OptionFields a) (String -> Maybe a) +optReader = lens _optReader $ \x o -> o { _optReader = x } + +flagNames :: Lens (FlagFields a) [OptName] +flagNames = lens _flagNames $ \x o -> o { _flagNames = x } + +cmdCommands :: Lens (CommandFields a) [(String, ParserInfo a)] +cmdCommands = lens _cmdCommands $ \x o -> o { _cmdCommands = x } + class HasName f where name :: OptName -> f a -> f a @@ -198,7 +204,7 @@ { _optMain = opt , _optMetaVar = "" , _optShow = True - , _optCont = Just . pure + , _optCont = return . pure , _optHelp = "" , _optDefault = Nothing } @@ -290,11 +296,14 @@ where base = ParserInfo { _infoParser = parser - , _infoFullDesc = True - , _infoHeader = "" - , _infoProgDesc = "" - , _infoFooter = "" - , _infoFailureCode = 1 } + , _infoDesc = ParserDesc + { _descFull = True + , _descProg = "" + , _descHeader = "" + , _descFooter = "" + , _descFailureCode = 1 + } + } -- | Trivial option modifier. idm :: Category hom => hom a a diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs --- a/Options/Applicative/Common.hs +++ b/Options/Applicative/Common.hs @@ -34,15 +34,22 @@ ParserInfo(..), -- * Running parsers - evalParser, runParser, + runParserFully, + evalParser, -- * Low-level utilities + runP, + setContext, mapParser, optionNames ) where import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Error +import Control.Monad.Trans.Writer import Data.Lens.Common import Data.Maybe import Data.Monoid @@ -90,8 +97,10 @@ | Just result <- f arg -> Just $ \args -> return (result, args) CmdReader _ f - | Just cmdInfo <- f arg - -> Just $ \args -> tryP $ runParser (cmdInfo^.infoParser) args + | Just subp <- f arg + -> Just $ \args -> do + setContext (Just arg) subp + runParser (subp^.infoParser) args _ -> Nothing where parsed @@ -107,36 +116,51 @@ | otherwise = Nothing tryP :: Maybe a -> P a -tryP = maybe ParseError return +tryP = maybe empty return +runP :: P a -> (Either String a, Context) +runP = runWriter . runErrorT + +setContext :: Maybe String -> ParserInfo a -> P () +setContext name = lift . tell . Context name + stepParser :: Parser a -> String -> [String] -> P (Parser a, [String]) -stepParser (NilP _) _ _ = ParseError +stepParser (NilP _) _ _ = empty stepParser (ConsP opt p) arg args | Just matcher <- optMatches (opt^.optMain) arg = do (r, args') <- matcher args - liftOpt' <- tryP $ getL optCont opt r + liftOpt' <- getL optCont opt r return (liftOpt' <*> p, args') | otherwise = do (p', args') <- stepParser p arg args return (ConsP opt p', args') -- | Apply a 'Parser' to a command line, and return a result and leftover --- arguments. This function returns 'Nothing' if any parsing error occurs, or +-- arguments. This function returns an error if any parsing error occurs, or -- if any options are missing and don't have a default value. -runParser :: Parser a -> [String] -> Maybe (a, [String]) +runParser :: Parser a -> [String] -> P (a, [String]) runParser p args = case args of [] -> result - (arg : argt) -> case stepParser p arg argt of - ParseError -> result - ParseResult (p', args') -> runParser p' args' + (arg : argt) -> do + x <- catchError (Right <$> stepParser p arg argt) + (return . Left) + case x of + Left e -> result <|> throwError e + Right (p', args') -> runParser p' args' where result = (,) <$> evalParser p <*> pure args --- | The default value of a 'Parser'. This function returns 'Nothing' if any --- of the options don't have a default value. -evalParser :: Parser a -> Maybe a +runParserFully :: Parser a -> [String] -> P a +runParserFully p args = do + (r, args') <- runParser p args + guard $ null args' + return r + +-- | The default value of a 'Parser'. This function returns an error if any of +-- the options don't have a default value. +evalParser :: Parser a -> P a evalParser (NilP r) = pure r -evalParser (ConsP opt p) = opt^.optDefault <*> evalParser p +evalParser (ConsP opt p) = tryP (opt^.optDefault) <*> evalParser p -- | Map a polymorphic function over all the options of a parser, and collect -- the results. diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} module Options.Applicative.Extra ( -- * Extra parser utilities -- @@ -28,13 +29,6 @@ & value id & hide ) --- | Result after a parse error. -data ParserFailure = ParserFailure - { errMessage :: String -> String -- ^ Function which takes the program name - -- as input and returns an error message - , errExitCode :: ExitCode -- ^ Exit code to use for this error - } - -- | Run a program description. -- -- Parse command line arguments. Display help text and exit if any parse error @@ -54,15 +48,33 @@ -> [String] -- ^ Program arguments -> Either ParserFailure a execParserPure pinfo args = - case runParser parser args of - Just (a, []) -> Right a - _ -> Left ParserFailure - { errMessage = \progn -> parserHelpText (add_usage progn pinfo) + case runP p of + (Right a, _) -> Right a + (Left msg, ctx) -> Left ParserFailure + { errMessage = \progn + -> with_context ctx pinfo $ \name -> + parserHelpText + . add_error msg + . add_usage name progn , errExitCode = ExitFailure (pinfo^.infoFailureCode) } where parser = pinfo^.infoParser - add_usage progn = modL infoHeader $ \h -> vcat [h, usage parser progn] + add_usage name progn i = + modL infoHeader + (\h -> vcat [h, usage (i^.infoParser) ename]) + i + where + ename = maybe progn (\n -> progn ++ " " ++ n) name + add_error msg = modL infoHeader $ \h -> vcat [msg, h] + with_context :: Context + -> ParserInfo a + -> (forall b . Maybe String -> ParserInfo b -> c) + -> c + with_context NullContext i f = f Nothing i + with_context (Context n i) _ f = f n i + + p = runParserFully parser args -- | Generate option summary. usage :: Parser a -> String -> String diff --git a/Options/Applicative/Help.hs b/Options/Applicative/Help.hs --- a/Options/Applicative/Help.hs +++ b/Options/Applicative/Help.hs @@ -44,10 +44,8 @@ in render desc' -- | Generate descriptions for commands. -cmdDesc :: Parser a -> String -cmdDesc = intercalate "\n" - . filter (not . null) - . mapParser desc +cmdDesc :: Parser a -> [String] +cmdDesc = concat . mapParser desc where desc opt | CmdReader cmds p <- opt^.optMain @@ -55,7 +53,7 @@ | cmd <- cmds , d <- maybeToList . fmap (getL infoProgDesc) $ p cmd ] | otherwise - = "" + = [] -- | Generate a brief help text for a parser. briefDesc :: Parser a -> String @@ -67,7 +65,7 @@ , descSurround = True } -- | Generate a full help text for a parser. -fullDesc :: Parser a -> String +fullDesc :: Parser a -> [String] fullDesc = tabulate . catMaybes . mapParser doc where doc opt @@ -86,11 +84,13 @@ parserHelpText pinfo = unlines $ nn [pinfo^.infoHeader] ++ [ " " ++ line | line <- nn [pinfo^.infoProgDesc] ] - ++ [ line | desc <- nn [fullDesc p] - , line <- ["", "Common options:", desc] + ++ [ line | let opts = fullDesc p + , not (null opts) + , line <- ["", "Common options:"] ++ opts , pinfo^.infoFullDesc ] - ++ [ line | desc <- nn [cmdDesc p] - , line <- ["", "Available commands:", desc] + ++ [ line | let cmds = cmdDesc p + , not (null cmds) + , line <- ["", "Available commands:"] ++ cmds , pinfo^.infoFullDesc ] ++ [ line | footer <- nn [pinfo^.infoFooter] , line <- ["", footer] ] diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -1,19 +1,29 @@ -{-# LANGUAGE GADTs, DeriveFunctor, TemplateHaskell #-} +{-# LANGUAGE GADTs, DeriveFunctor #-} module Options.Applicative.Types ( ParserInfo(..), + ParserDesc(..), + Context(..), + P, infoParser, + infoDesc, infoFullDesc, infoProgDesc, infoHeader, infoFooter, infoFailureCode, + descFull, + descProg, + descHeader, + descFooter, + descFailureCode, + Option(..), OptName(..), OptReader(..), Parser(..), - P(..), + ParserFailure(..), optMain, optDefault, @@ -24,20 +34,41 @@ ) where import Control.Applicative +import Control.Category import Control.Monad -import Data.Lens.Template +import Control.Monad.Trans.Error +import Control.Monad.Trans.Writer +import Data.Lens.Common +import Data.Monoid +import Prelude hiding ((.), id) +import System.Exit -- | A full description for a runnable 'Parser' for a program. data ParserInfo a = ParserInfo { _infoParser :: Parser a -- ^ the option parser for the program - , _infoFullDesc :: Bool -- ^ whether the help text should contain full documentation - , _infoProgDesc :: String -- ^ brief parser description - , _infoHeader :: String -- ^ header of the full parser description - , _infoFooter :: String -- ^ footer of the full parser description - , _infoFailureCode :: Int -- ^ exit code for a parser failure + , _infoDesc :: ParserDesc -- ^ description of the parser } deriving Functor +-- | Attributes that can be associated to a 'Parser'. +data ParserDesc = ParserDesc + { _descFull:: Bool -- ^ whether the help text should contain full documentation + , _descProg:: String -- ^ brief parser description + , _descHeader :: String -- ^ header of the full parser description + , _descFooter :: String -- ^ footer of the full parser description + , _descFailureCode :: Int -- ^ exit code for a parser failure + } +data Context where + Context :: Maybe String -> ParserInfo a -> Context + NullContext :: Context + +instance Monoid Context where + mempty = NullContext + mappend _ c@(Context _ _) = c + mappend c _ = c + +type P = ErrorT String (Writer Context) + data OptName = OptShort !Char | OptLong !String deriving (Eq, Ord) @@ -49,7 +80,7 @@ , _optShow :: Bool -- ^ whether this flag is shown is the brief description , _optHelp :: String -- ^ help text for this option , _optMetaVar :: String -- ^ metavariable for this option - , _optCont :: r -> Maybe (Parser a) } -- ^ option continuation + , _optCont :: r -> P (Parser a) } -- ^ option continuation deriving Functor -- | An 'OptReader' defines whether an option matches an command line argument. @@ -77,19 +108,70 @@ ConsP opt p1 <*> p2 = ConsP (fmap uncurry opt) $ (,) <$> p1 <*> p2 -data P a - = ParseError - | ParseResult a - deriving Functor +-- | Result after a parse error. +data ParserFailure = ParserFailure + { errMessage :: String -> String -- ^ Function which takes the program name + -- as input and returns an error message + , errExitCode :: ExitCode -- ^ Exit code to use for this error + } -instance Monad P where - return = ParseResult - ParseError >>= _ = ParseError - ParseResult a >>= f = f a - fail _ = ParseError +instance Error ParserFailure where + strMsg msg = ParserFailure + { errMessage = \_ -> msg + , errExitCode = ExitFailure 1 } -instance Applicative P where - pure = return - (<*>) = ap +-- lenses -$( makeLenses [''Option, ''ParserInfo] ) +optMain :: Lens (Option r a) (OptReader r) +optMain = lens _optMain $ \x o -> o { _optMain = x } + +optDefault :: Lens (Option r a) (Maybe a) +optDefault = lens _optDefault $ \x o -> o { _optDefault = x } + +optShow :: Lens (Option r a) Bool +optShow = lens _optShow $ \x o -> o { _optShow = x } + +optHelp :: Lens (Option r a) String +optHelp = lens _optHelp $ \x o -> o { _optHelp = x } + +optMetaVar :: Lens (Option r a) String +optMetaVar = lens _optMetaVar $ \x o -> o { _optMetaVar = x } + +optCont :: Lens (Option r a) (r -> P (Parser a)) +optCont = lens _optCont $ \x o -> o { _optCont = x } + +descFull :: Lens ParserDesc Bool +descFull = lens _descFull $ \x p -> p { _descFull = x } + +descProg :: Lens ParserDesc String +descProg = lens _descProg $ \x p -> p { _descProg = x } + +descHeader :: Lens ParserDesc String +descHeader = lens _descHeader $ \x p -> p { _descHeader = x } + +descFooter :: Lens ParserDesc String +descFooter = lens _descFooter $ \x p -> p { _descFooter = x } + +descFailureCode :: Lens ParserDesc Int +descFailureCode = lens _descFailureCode $ \x p -> p { _descFailureCode = x } + +infoParser :: Lens (ParserInfo a) (Parser a) +infoParser = lens _infoParser $ \x p -> p { _infoParser = x } + +infoDesc :: Lens (ParserInfo a) ParserDesc +infoDesc = lens _infoDesc $ \x p -> p { _infoDesc = x } + +infoFullDesc :: Lens (ParserInfo a) Bool +infoFullDesc = descFull . infoDesc + +infoProgDesc :: Lens (ParserInfo a) String +infoProgDesc = descProg . infoDesc + +infoHeader :: Lens (ParserInfo a) String +infoHeader = descHeader . infoDesc + +infoFooter :: Lens (ParserInfo a) String +infoFooter = descFooter . infoDesc + +infoFailureCode :: Lens (ParserInfo a) Int +infoFailureCode = descFailureCode . infoDesc diff --git a/Options/Applicative/Utils.hs b/Options/Applicative/Utils.hs --- a/Options/Applicative/Utils.hs +++ b/Options/Applicative/Utils.hs @@ -17,13 +17,13 @@ vcat :: [String] -> String vcat = intercalate "\n\n" . filter (not . null) -tabulate' :: Int -> [(String, String)] -> String -tabulate' size table = unlines +tabulate' :: Int -> [(String, String)] -> [String] +tabulate' size table = [ " " ++ pad size key ++ " " ++ value | (key, value) <- table ] -- | Display pairs of strings in a table. -tabulate :: [(String, String)] -> String +tabulate :: [(String, String)] -> [String] tabulate = tabulate' 24 -- | Pad a string to a fixed size with whitespace. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,7 +33,7 @@ ```haskell greet :: Sample -> IO () -greet (Sample h True) = putStrLn $ "Hello, " ++ h +greet (Sample h False) = putStrLn $ "Hello, " ++ h greet _ = return () main :: IO () diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -1,5 +1,5 @@ name: optparse-applicative -version: 0.0.1 +version: 0.1.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser: @@ -28,7 +28,7 @@ . @ greet :: Sample -> IO () - greet (Sample h True) = putStrLn $ \"Hello, \" ++ h + greet (Sample h False) = putStrLn $ \"Hello, \" ++ h greet _ = return () . main :: IO () @@ -81,15 +81,15 @@ Options.Applicative.Help build-depends: base == 4.*, data-lens == 2.10.*, - data-lens-template == 2.1.*, - data-default == 0.4.* + data-default == 0.4.*, + transformers >= 0.2 && < 0.4 test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Tests.hs build-depends: base == 4.*, HUnit == 1.2.*, - optparse-applicative == 0.0.*, + optparse-applicative == 0.1.*, test-framework == 0.6.*, test-framework-hunit == 0.2.*, test-framework-th-prime == 0.0.* diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -3,6 +3,7 @@ import qualified Examples.Hello as Hello import qualified Examples.Commands as Commands +import qualified Examples.Cabal as Cabal import Options.Applicative.Extra import Options.Applicative.Types @@ -16,19 +17,22 @@ where err b = assertFailure $ "expected Left, got " ++ show b -checkHelpText :: Show a => String -> ParserInfo a -> Assertion -checkHelpText name p = do - let result = execParserPure p ["--help"] +checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion +checkHelpText name p args = do + let result = execParserPure p args assertLeft result $ \(ParserFailure err code) -> do expected <- readFile $ "tests/" ++ name ++ ".err.txt" expected @=? err name ExitFailure 1 @=? code case_hello :: Assertion -case_hello = checkHelpText "hello" Hello.opts +case_hello = checkHelpText "hello" Hello.opts ["--help"] case_modes :: Assertion -case_modes = checkHelpText "commands" Commands.opts +case_modes = checkHelpText "commands" Commands.opts ["--help"] + +case_cabal :: Assertion +case_cabal = checkHelpText "cabal" Cabal.pinfo ["configure", "--help"] main :: IO () main = $(defaultMainGenerator)