diff --git a/getopt-generics.cabal b/getopt-generics.cabal --- a/getopt-generics.cabal +++ b/getopt-generics.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: getopt-generics -version: 0.7 +version: 0.7.1 synopsis: Simple command line argument parsing description: "getopt-generics" tries to make it very simple to create command line argument parsers. An introductory example can be found in the . category: Console, System diff --git a/src/System/Console/GetOpt/Generics.hs b/src/System/Console/GetOpt/Generics.hs --- a/src/System/Console/GetOpt/Generics.hs +++ b/src/System/Console/GetOpt/Generics.hs @@ -46,7 +46,7 @@ import Prelude.Compat import Data.Char -import Data.List +import Data.List.Compat import Data.Maybe import Data.Proxy import Data.Typeable @@ -126,7 +126,7 @@ processFields progName modifiers args fields = do initialFieldStates <- mkInitialFieldStates modifiers fields - showHelp + showOutputInfo let (options, arguments, parseErrors) = getOpt Permute (mkOptDescrs modifiers fields) args @@ -140,8 +140,8 @@ to . SOP . Z <$> collectResult withPositionalArguments where - showHelp :: Result () - showHelp = helpWrapper progName modifiers args fields + showOutputInfo :: Result () + showOutputInfo = outputInfo progName modifiers args fields reportGetOptErrors :: [String] -> Result () reportGetOptErrors parseErrors = case parseErrors of @@ -197,26 +197,38 @@ show (typeOf (impossible "mkInitialFieldStates" :: x))] else return $ _emptyOption name - --- * showing help? +-- * showing output information -data HelpFlag = HelpFlag +data OutputInfoFlag + = HelpFlag + | VersionFlag String + deriving (Eq, Ord) --- Outputs the help if the help flag is given. -helpWrapper :: (SingI xs, All Option xs) => +-- Outputs the help or version information if the corresponding flags are given. +outputInfo :: (SingI xs, All Option xs) => String -> Modifiers -> [String] -> NP (Field :.: FieldInfo) xs -> Result () -helpWrapper progName modifiers args fields = - case getOpt Permute [helpOption] args of +outputInfo progName modifiers args fields = + case (\ (a, b, c) -> (sort a, b, c)) (getOpt Permute options args) of ([], _, _) -> return () - -- no help flag given + -- no help or version flag given (HelpFlag : _, _, _) -> OutputAndExit $ stripTrailingSpaces $ usageInfo header $ toOptDescrUnit (mkOptDescrs modifiers fields) ++ - toOptDescrUnit [helpOption] + toOptDescrUnit options + (VersionFlag version : _, _, _) -> OutputAndExit $ + progName ++ " version " ++ version ++ "\n" where - helpOption :: OptDescr HelpFlag + options :: [OptDescr OutputInfoFlag] + options = helpOption : maybeToList versionOption + + helpOption :: OptDescr OutputInfoFlag helpOption = Option ['h'] ["help"] (NoArg HelpFlag) "show help and exit" + + versionOption :: Maybe (OptDescr OutputInfoFlag) + versionOption = case getVersion modifiers of + Just version -> Just $ Option [] ["version"] (NoArg (VersionFlag version)) "show version and exit" + Nothing -> Nothing toOptDescrUnit :: [OptDescr a] -> [OptDescr ()] toOptDescrUnit = map (fmap (const ())) diff --git a/src/System/Console/GetOpt/Generics/Modifier.hs b/src/System/Console/GetOpt/Generics/Modifier.hs --- a/src/System/Console/GetOpt/Generics/Modifier.hs +++ b/src/System/Console/GetOpt/Generics/Modifier.hs @@ -12,6 +12,7 @@ isPositionalArgumentsField, getPositionalArgumentType, getHelpText, + getVersion, deriveShortOptions, @@ -50,42 +51,50 @@ | AddOptionHelp String String -- ^ @AddOptionHelp fieldName helpText@ adds a help text for the option -- @fieldName@. + | AddVersionFlag String + -- ^ @AddVersionFlag version@ adds a @--version@ flag. deriving (Show, Eq, Ord) data Modifiers = Modifiers { _shortOptions :: [(String, [Char])], _renamings :: [(String, String)], positionalArgumentsField :: Maybe (String, String), - helpTexts :: [(String, String)] + helpTexts :: [(String, String)], + version :: Maybe String } deriving (Show, Eq, Ord) mkModifiers :: [Modifier] -> Result Modifiers -mkModifiers = foldM inner (Modifiers [] [] Nothing []) +mkModifiers = foldM inner empty where + empty :: Modifiers + empty = Modifiers [] [] Nothing [] Nothing + inner :: Modifiers -> Modifier -> Result Modifiers - inner (Modifiers shorts renamings args help) modifier = case modifier of + inner (Modifiers shorts renamings args help version) modifier = case modifier of (AddShortOption option short) -> do normalized <- normalizeFieldName option return $ Modifiers (insertWith (++) normalized [short] shorts) - renamings args help + renamings args help version (RenameOption from to) -> do fromNormalized <- normalizeFieldName from - return $ Modifiers shorts (insert fromNormalized to renamings) args help + return $ Modifiers shorts (insert fromNormalized to renamings) args help version (UseForPositionalArguments option typ) -> do normalized <- normalizeFieldName option - return $ Modifiers shorts renamings (Just (normalized, map toUpper typ)) help + return $ Modifiers shorts renamings (Just (normalized, map toUpper typ)) help version (AddOptionHelp option helpText) -> do normalized <- normalizeFieldName option - return $ Modifiers shorts renamings args (insert normalized helpText help) + return $ Modifiers shorts renamings args (insert normalized helpText help) version + (AddVersionFlag v) -> do + return $ Modifiers shorts renamings args help (Just v) mkShortOptions :: Modifiers -> String -> [Char] -mkShortOptions (Modifiers shortMap _ _ _) option = +mkShortOptions (Modifiers shortMap _ _ _ _) option = fromMaybe [] (lookup option shortMap) mkLongOption :: Modifiers -> String -> String -mkLongOption (Modifiers _ renamings _ _) option = +mkLongOption (Modifiers _ renamings _ _ _) option = fromMaybe option (lookup option renamings) hasPositionalArgumentsField :: Modifiers -> Bool @@ -100,6 +109,9 @@ getHelpText :: Modifiers -> String -> String getHelpText modifiers field = fromMaybe "" (lookup field (helpTexts modifiers)) + +getVersion :: Modifiers -> Maybe String +getVersion modifiers = version modifiers -- * deriving Modifiers diff --git a/test/System/Console/GetOpt/Generics/ModifierSpec.hs b/test/System/Console/GetOpt/Generics/ModifierSpec.hs --- a/test/System/Console/GetOpt/Generics/ModifierSpec.hs +++ b/test/System/Console/GetOpt/Generics/ModifierSpec.hs @@ -6,7 +6,7 @@ import Data.Proxy import qualified GHC.Generics import Test.Hspec -import Test.QuickCheck hiding (Result) +import Test.QuickCheck hiding (Result(..)) import System.Console.GetOpt.Generics import System.Console.GetOpt.Generics.Modifier @@ -30,6 +30,11 @@ it "combines existing values with the given function" $ do insertWith (++) (1 :: Integer) "bar" [(1, "foo")] `shouldBe` [(1, "foobar")] + + describe "getVersion" $ do + it "returns the version" $ do + let Success modifiers = mkModifiers [AddVersionFlag "1.0.0"] + getVersion modifiers `shouldBe` Just "1.0.0" context "when used with Modifiers" $ do describe "parseArguments" $ do diff --git a/test/System/Console/GetOpt/GenericsSpec.hs b/test/System/Console/GetOpt/GenericsSpec.hs --- a/test/System/Console/GetOpt/GenericsSpec.hs +++ b/test/System/Console/GetOpt/GenericsSpec.hs @@ -9,7 +9,7 @@ import Control.Exception import Data.Foldable (forM_) -import Data.List (isPrefixOf, isSuffixOf) +import Data.List (isInfixOf, isPrefixOf, isSuffixOf) import Data.Typeable import qualified GHC.Generics as GHC import System.Environment @@ -31,6 +31,7 @@ part5 part6 part7 + part8 data Foo = Foo { @@ -432,3 +433,19 @@ it "renders as NUMBER in help and error output" $ do argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER" + +part8 :: Spec +part8 = do + describe "parseArgument" $ do + context "--version" $ do + it "implements --version" $ do + let OutputAndExit output = parseArguments "foo" [AddVersionFlag "1.0.0"] (words "--version") :: Result Foo + output `shouldBe` "foo version 1.0.0\n" + + it "--help takes precedence over --version" $ do + let OutputAndExit output = parseArguments "foo" [AddVersionFlag "1.0.0"] (words "--version --help") :: Result Foo + output `shouldSatisfy` ("show help and exit" `isInfixOf`) + + it "--version shows up in help output" $ do + let OutputAndExit output = parseArguments "foo" [AddVersionFlag "1.0.0"] (words "--help") :: Result Foo + output `shouldSatisfy` ("show version and exit" `isInfixOf`)