packages feed

optparse-applicative 0.0.1 → 0.1.0

raw patch · 9 files changed

+215/−84 lines, 9 filesdep +transformersdep −data-lens-templatedep ~optparse-applicative

Dependencies added: transformers

Dependencies removed: data-lens-template

Dependency ranges changed: optparse-applicative

Files

Options/Applicative/Builder.hs view
@@ -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
Options/Applicative/Common.hs view
@@ -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.
Options/Applicative/Extra.hs view
@@ -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
Options/Applicative/Help.hs view
@@ -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] ]
Options/Applicative/Types.hs view
@@ -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
Options/Applicative/Utils.hs view
@@ -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.
README.md view
@@ -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 ()
optparse-applicative.cabal view
@@ -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.*
tests/Tests.hs view
@@ -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)