diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Example where + +import qualified GHC.Generics +import System.Console.GetOpt.Generics + +-- we specify a data type that maps to the commandline arguments + +data Foo + = Foo { + bar :: String + , baz :: Maybe String + , qux :: Int + } + deriving (Eq, Show, GHC.Generics.Generic) + +instance Generic Foo +instance HasDatatypeInfo Foo + +-- give it go + +main :: IO () +main = do + myFoo <- getArguments + print $ bar myFoo + print $ baz myFoo + print $ qux myFoo diff --git a/getopt-generics.cabal b/getopt-generics.cabal --- a/getopt-generics.cabal +++ b/getopt-generics.cabal @@ -1,13 +1,13 @@ --- This file has been generated from package.yaml by Cabalize. +-- This file has been generated from package.yaml by hpack. -- --- see: https://github.com/sol/cabalize +-- see: https://github.com/sol/hpack name: getopt-generics -version: 0.5 +version: 0.6 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 . +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 +bug-reports: https://github.com/zalora/getopt-generics/issues author: Linh Nguyen, Sönke Hahn maintainer: linh.nguyen@zalora.com, soenke.hahn@zalora.com copyright: Zalora South East Asia Pte Ltd @@ -40,6 +40,17 @@ type: exitcode-stdio-1.0 hs-source-dirs: src, test, examples main-is: Spec.hs + other-modules: + System.Console.GetOpt.Generics.Internal + System.Console.GetOpt.Generics.Modifier + System.Console.GetOpt.Generics.Result + System.Console.GetOpt.Generics + ExamplesSpec + System.Console.GetOpt.Generics.InternalSpec + System.Console.GetOpt.Generics.ModifierSpec + System.Console.GetOpt.Generics.ResultSpec + System.Console.GetOpt.GenericsSpec + Example build-depends: base == 4.* , base-compat >= 0.7 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 @@ -33,6 +33,10 @@ deriveShortOptions, -- * Available Field Types Option(..), + -- * Re-exports from "Generics.SOP" + Generic, + HasDatatypeInfo, + Proxy(..) ) where import Prelude () @@ -167,7 +171,7 @@ (mkShortOptions modifiers name) [mkLongOption modifiers name] _toOption - "" + (getHelpText modifiers name) toOptDescr :: NS OptDescrE xs -> Maybe (OptDescr (NS FieldState xs)) toOptDescr (Z (OptDescrE (Just a))) = Just $ fmap Z a 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 @@ -10,6 +10,7 @@ mkLongOption, hasPositionalArgumentsField, isPositionalArgumentsField, + getHelpText, deriveShortOptions, @@ -39,37 +40,45 @@ -- ^ @UseForPositionalArguments fieldName@ fills the field addressed by -- @fieldName@ with the positional arguments (i.e. arguments that don't -- correspond to a flag). The field has to have type @['String']@. + | AddOptionHelp String String + -- ^ @AddOptionHelp fieldName helpText@ adds a help text for the option + -- @fieldName@. deriving (Show, Eq, Ord) data Modifiers = Modifiers { _shortOptions :: [(String, [Char])], _renamings :: [(String, String)], - positionalArgumentsField :: Maybe String + positionalArgumentsField :: Maybe String, + helpTexts :: [(String, String)] } deriving (Show, Eq, Ord) mkModifiers :: [Modifier] -> Result Modifiers -mkModifiers = foldM inner (Modifiers [] [] Nothing) +mkModifiers = foldM inner (Modifiers [] [] Nothing []) where inner :: Modifiers -> Modifier -> Result Modifiers - inner (Modifiers shorts renamings args) (AddShortOption option short) = do - normalized <- normalizeFieldName option - return $ Modifiers - (insertWith (++) normalized [short] shorts) - renamings args - inner (Modifiers shorts renamings args) (RenameOption from to) = do - fromNormalized <- normalizeFieldName from - return $ Modifiers shorts (insert fromNormalized to renamings) args - inner (Modifiers shorts renamings _) (UseForPositionalArguments option) = do - normalized <- normalizeFieldName option - return $ Modifiers shorts renamings (Just normalized) + inner (Modifiers shorts renamings args help) modifier = case modifier of + (AddShortOption option short) -> do + normalized <- normalizeFieldName option + return $ Modifiers + (insertWith (++) normalized [short] shorts) + renamings args help + (RenameOption from to) -> do + fromNormalized <- normalizeFieldName from + return $ Modifiers shorts (insert fromNormalized to renamings) args help + (UseForPositionalArguments option) -> do + normalized <- normalizeFieldName option + return $ Modifiers shorts renamings (Just normalized) help + (AddOptionHelp option helpText) -> do + normalized <- normalizeFieldName option + return $ Modifiers shorts renamings args (insert normalized helpText help) 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 @@ -78,6 +87,9 @@ isPositionalArgumentsField :: Modifiers -> String -> Bool isPositionalArgumentsField modifiers field = Just field == positionalArgumentsField modifiers + +getHelpText :: Modifiers -> String -> String +getHelpText modifiers field = fromMaybe "" (lookup field (helpTexts modifiers)) -- * deriving Modifiers diff --git a/test/ExamplesSpec.hs b/test/ExamplesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExamplesSpec.hs @@ -0,0 +1,10 @@ + +module ExamplesSpec where + +import Test.Hspec + +import Example () +import Readme () + +spec :: Spec +spec = return () diff --git a/test/System/Console/GetOpt/Generics/InternalSpec.hs b/test/System/Console/GetOpt/Generics/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Console/GetOpt/Generics/InternalSpec.hs @@ -0,0 +1,45 @@ + +module System.Console.GetOpt.Generics.InternalSpec where + +import Data.Char +import Test.Hspec +import Test.QuickCheck hiding (Success) + +import System.Console.GetOpt.Generics.Internal +import System.Console.GetOpt.Generics.Result + +spec :: Spec +spec = do + describe "normalizeFieldName" $ do + it "is idempotent" $ do + property $ \ x -> + (normalizeFieldName =<< normalizeFieldName x) + `shouldBe` normalizeFieldName x + + it "contains only valid characters" $ do + property $ \ x -> + case normalizeFieldName x of + Success s -> s `shouldSatisfy` + (\ s -> all (\ c -> c `elem` ['a' .. 'z'] || c == '-') s) + _ -> return () + + it "complains on field names without alphabetic characters" $ do + property $ + forAll (listOf (elements "-_$/|\\#~_[]")) $ \ s -> + normalizeFieldName s `shouldBe` + Errors [("unsupported field name: " ++ s)] + + it "replaces camelCase with dashes" $ + property $ + \ prefix suffix -> + (fmap (not . null) (normalizeFieldName prefix) == Success True) ==> + forAll upperCaseChar $ \ upper -> + counterexample (prefix ++ [upper] ++ suffix) $ + normalizeFieldName (prefix ++ [upper] ++ suffix) + `shouldBe` do + normalizedPrefix <- normalizeFieldName prefix + normalizedRest <- normalizeFieldName (toLower upper : suffix) + return $ normalizedPrefix ++ "-" ++ normalizedRest + +upperCaseChar :: Gen Char +upperCaseChar = elements ['A' .. 'Z'] diff --git a/test/System/Console/GetOpt/Generics/ModifierSpec.hs b/test/System/Console/GetOpt/Generics/ModifierSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Console/GetOpt/Generics/ModifierSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveGeneric #-} + +module System.Console.GetOpt.Generics.ModifierSpec where + +import Data.Char +import Data.Proxy +import qualified GHC.Generics +import Test.Hspec +import Test.QuickCheck hiding (Result) + +import System.Console.GetOpt.Generics +import System.Console.GetOpt.Generics.Modifier + +spec :: Spec +spec = do + describe "deriveShortOptions" $ do + it "includes modifiers for short options" $ do + deriveShortOptions (Proxy :: Proxy Foo) `shouldBe` [AddShortOption "bar" 'b'] + + it "doesn't include modifiers for short options in case of overlaps" $ do + deriveShortOptions (Proxy :: Proxy Overlap) `shouldBe` [] + + describe "mkShortModifiers" $ do + it "returns only lower-case ascii alpha characters as short options" $ do + property $ \ strings -> + mkShortModifiers strings `shouldSatisfy` all (\ (AddShortOption _ c) -> + isLower c && isAscii c && isAlpha c) + + describe "insertWith" $ do + it "combines existing values with the given function" $ do + insertWith (++) (1 :: Integer) "bar" [(1, "foo")] + `shouldBe` [(1, "foobar")] + + context "when used with Modifiers" $ do + describe "parseArguments" $ do + it "allows to specify a flag specific help" $ do + let OutputAndExit output = + parseArguments "header" [AddOptionHelp "bar" "bar help text"] + (words "--help") :: Result Foo + output `shouldContain` "--bar=string bar help text" + +data Foo + = Foo { + bar :: String + } + deriving (GHC.Generics.Generic) + +instance Generic Foo +instance HasDatatypeInfo Foo + +data Overlap + = Overlap { + foo :: String, + fooo :: String + } + deriving (GHC.Generics.Generic) + +instance Generic Overlap +instance HasDatatypeInfo Overlap diff --git a/test/System/Console/GetOpt/Generics/ResultSpec.hs b/test/System/Console/GetOpt/Generics/ResultSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Console/GetOpt/Generics/ResultSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Console.GetOpt.Generics.ResultSpec where + +import Test.Hspec + +import System.Console.GetOpt.Generics.Result + +spec :: Spec +spec = do + describe "Result" $ do + context ">>" $ do + it "collects errors" $ do + (Errors ["foo"] >> Errors ["bar"] :: Result ()) + `shouldBe` Errors ["foo", "bar"] diff --git a/test/System/Console/GetOpt/GenericsSpec.hs b/test/System/Console/GetOpt/GenericsSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Console/GetOpt/GenericsSpec.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Console.GetOpt.GenericsSpec where + +import Control.Exception +import Data.Foldable (forM_) +import Data.List +import Data.Typeable +import qualified GHC.Generics as GHC +import System.Environment +import System.Exit +import System.IO +import System.IO.Silently +import Test.Hspec +import Test.Hspec.Expectations.Contrib + +import System.Console.GetOpt.Generics + +spec :: Spec +spec = do + part1 + part2 + part3 + part4 + part5 + part6 + +data Foo + = Foo { + bar :: Maybe Int, + baz :: String, + bool :: Bool + } + deriving (GHC.Generic, Show, Eq) + +instance Generic Foo +instance HasDatatypeInfo Foo + +data NotAllowed = NotAllowed + deriving (GHC.Generic, Show, Eq) + +instance Generic NotAllowed +instance HasDatatypeInfo NotAllowed + +part1 :: Spec +part1 = do + describe "getArguments" $ do + it "parses command line arguments" $ do + withArgs (words "--bar 4 --baz foo") $ + getArguments `shouldReturn` Foo (Just 4) "foo" False + + it "allows optional arguments" $ do + withArgs (words "--baz foo") $ + getArguments `shouldReturn` Foo Nothing "foo" False + + it "allows boolean flags" $ do + withArgs (words "--bool --baz foo") $ + getArguments `shouldReturn` Foo Nothing "foo" True + + context "with invalid arguments" $ do + it "doesn't execute the action" $ do + let main = withArgs (words "--invalid") $ do + _ :: Foo <- getArguments + throwIO (ErrorCall "action") + main `shouldThrow` (== ExitFailure 1) + + it "prints out an error" $ do + output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ + withArgs (words "--no-such-option") $ do + _ :: Foo <- getArguments + return () + output `shouldContain` "unrecognized" + output `shouldContain` "--no-such-option" + + it "prints errors for missing options" $ do + output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ + withArgs [] $ do + _ :: Foo <- getArguments + return () + output `shouldContain` "missing option: --baz=string" + + it "prints out an error for unparseable options" $ do + output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ + withArgs (words "--bar foo --baz huhu") $ do + _ :: Foo <- getArguments + return () + output `shouldContain` "cannot parse as integer (optional): foo" + + it "complains about invalid overwritten options" $ do + output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ + withArgs (words "--bar foo --baz huhu --bar 12") $ do + _ :: Foo <- getArguments + return () + output `shouldContain` "cannot parse as integer (optional): foo" + + context "--help" $ do + it "implements --help" $ do + output <- capture_ $ withArgs ["--help"] $ + handle (\ (_ :: SomeException) -> return ()) $ do + _ :: Foo <- getArguments + return () + mapM_ (output `shouldContain`) $ + "--bar=integer" : "optional" : + "--baz=string" : + "--bool" : + [] + + it "throws ExitSuccess" $ do + withArgs ["--help"] (getArguments :: IO Foo) + `shouldThrow` (== ExitSuccess) + + it "contains help message about --help" $ do + output <- capture_ $ withArgs ["--help"] $ + handle (\ (_ :: SomeException) -> return ()) $ do + _ :: Foo <- getArguments + return () + output `shouldContain` "show help and exit" + + it "does not contain trailing spaces" $ do + output <- capture_ $ withArgs ["--help"] $ + handle (\ (_ :: SomeException) -> return ()) $ do + _ :: Foo <- getArguments + return () + forM_ (lines output) $ \ line -> + line `shouldSatisfy` (not . (" " `isSuffixOf`)) + + it "throws an exception when the options datatype is not allowed" $ do + output <- hCapture_ [stderr] $ + withArgs ["--help"] $ + handle (\ (_ :: SomeException) -> return ()) $ do + _ :: NotAllowed <- getArguments + return () + output `shouldContain` "doesn't support constructors without field labels" + + describe "parseArguments" $ do + it "allows to overwrite String options" $ do + parseArguments "header" [] (words "--baz one --baz two") + `shouldBe` Success (Foo Nothing "two" False) + +data ListOptions + = ListOptions { + multiple :: [Int] + } + deriving (GHC.Generic, Show, Eq) + +instance Generic ListOptions +instance HasDatatypeInfo ListOptions + +part2 :: Spec +part2 = do + describe "getArguments" $ do + it "allows to interpret multiple uses of the same option as lists" $ do + withArgs (words "--multiple 23 --multiple 42") $ do + getArguments `shouldReturn` ListOptions [23, 42] + + it "complains about invalid list arguments" $ do + output <- hCapture_ [stderr] $ + withArgs (words "--multiple foo --multiple 13") $ + handle (\ (_ :: SomeException) -> return ()) $ do + _ :: ListOptions <- getArguments + return () + output `shouldContain` "cannot parse as integer (multiple possible): foo" + +data CamelCaseOptions + = CamelCaseOptions { + camelCase :: String + } + deriving (GHC.Generic, Show, Eq) + +instance Generic CamelCaseOptions +instance HasDatatypeInfo CamelCaseOptions + +part3 :: Spec +part3 = do + describe "getArguments" $ do + it "turns camelCase selectors to lowercase and seperates with a dash" $ do + withArgs (words "--camel-case foo") $ do + getArguments `shouldReturn` CamelCaseOptions "foo" + + describe "parseArguments" $ do + it "help does not contain camelCase flags" $ do + let OutputAndExit output :: Result CamelCaseOptions + = parseArguments "header" [] ["--help"] + output `shouldNotContain` "camelCase" + output `shouldContain` "camel-case" + + it "error messages don't contain camelCase flags" $ do + let Errors errs :: Result CamelCaseOptions + = parseArguments "header" [] ["--bla"] + show errs `shouldNotContain` "camelCase" + show errs `shouldContain` "camel-case" + + context "AddShortOption" $ do + it "allows modifiers for short options" $ do + parseArguments "header" [AddShortOption "camel-case" 'x'] (words "-x foo") + `shouldBe` Success (CamelCaseOptions "foo") + + it "allows modifiers in camelCase" $ do + parseArguments "header" [AddShortOption "camelCase" 'x'] (words "-x foo") + `shouldBe` Success (CamelCaseOptions "foo") + + let parse :: [String] -> Result CamelCaseOptions + parse = parseArguments "header" [AddShortOption "camelCase" 'x'] + it "includes the short option in the help" $ do + let OutputAndExit output = parse ["--help"] + output `shouldContain` "-x string" + + context "RenameOption" $ do + it "allows to rename options" $ do + parseArguments "header" [RenameOption "camelCase" "bla"] (words "--bla foo") + `shouldBe` Success (CamelCaseOptions "foo") + + let parse = parseArguments "header" + [RenameOption "camelCase" "foo", RenameOption "camelCase" "bar"] + it "allows to shadow earlier modifiers with later modifiers" $ do + parse (words "--bar foo") + `shouldBe` Success (CamelCaseOptions "foo") + let Errors errs = parse (words "--foo foo") + show errs `shouldContain` "unknown argument: foo" + + it "contains renamed options in error messages" $ do + let Errors errs = parse [] + show errs `shouldNotContain` "camelCase" + show errs `shouldContain` "camel-case" + + it "allows to address fields in Modifiers in slugified form" $ do + parseArguments "header" [RenameOption "camel-case" "foo"] (words "--foo bar") + `shouldBe` Success (CamelCaseOptions "bar") + +data WithUnderscore + = WithUnderscore { + _withUnderscore :: String + } + deriving (GHC.Generic, Show, Eq) + +instance Generic WithUnderscore +instance HasDatatypeInfo WithUnderscore + +part4 :: Spec +part4 = do + describe "parseArguments" $ do + it "ignores leading underscores in field names" $ do + parseArguments "header" [] (words "--with-underscore foo") + `shouldBe` Success (WithUnderscore "foo") + +data WithPositionalArguments + = WithPositionalArguments { + positionalArguments :: [String], + someFlag :: Bool + } + deriving (GHC.Generic, Show, Eq) + +instance Generic WithPositionalArguments +instance HasDatatypeInfo WithPositionalArguments + +part5 :: Spec +part5 = do + describe "parseArguments" $ do + context "UseForPositionalArguments" $ do + it "allows positionalArguments" $ do + parseArguments "header" + [UseForPositionalArguments "positionalArguments"] + (words "foo bar --some-flag") + `shouldBe` Success (WithPositionalArguments ["foo", "bar"] True) + + it "disallows to specify the option used for positional arguments" $ do + parseArguments "header" + [UseForPositionalArguments "positionalArguments"] + (words "--positional-arguments foo") + `shouldBe` + (Errors ["unrecognized option `--positional-arguments'\n"] + :: Result WithPositionalArguments) + + it "complains about fields that don't have type [String]" $ do + parseArguments "header" + [UseForPositionalArguments "someFlag"] + (words "doesn't matter") + `shouldBe` + (Errors ["UseForPositionalArguments can only be used for fields of type [String] not Bool"] + :: Result WithPositionalArguments) + +data CustomFields + = CustomFields { + custom :: Custom, + customList :: [Custom], + customMaybe :: Maybe Custom + } + deriving (GHC.Generic, Show, Eq) + +instance Generic CustomFields +instance HasDatatypeInfo CustomFields + +data Custom + = CFoo + | CBar + | CBaz + deriving (Show, Eq, Typeable) + +instance Option Custom where + argumentType Proxy = "custom" + parseArgument x = case x of + "foo" -> Just CFoo + "bar" -> Just CBar + "baz" -> Just CBaz + _ -> Nothing + +part6 :: Spec +part6 = do + describe "parseArguments" $ do + context "CustomFields" $ do + it "allows easy implementation of custom field types" $ do + parseArguments "header" [] + (words "--custom foo --custom-list bar --custom-maybe baz") + `shouldBe` + Success (CustomFields CFoo [CBar] (Just CBaz))