getopt-generics 0.5 → 0.6

raw patch · 9 files changed

+522/−21 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/Example.hs +28/−0
• getopt-generics.cabal +16/−5
• src/System/Console/GetOpt/Generics.hs +5/−1
• src/System/Console/GetOpt/Generics/Modifier.hs +27/−15
• test/ExamplesSpec.hs +10/−0
• test/System/Console/GetOpt/Generics/InternalSpec.hs +45/−0
• test/System/Console/GetOpt/Generics/ModifierSpec.hs +59/−0
• test/System/Console/GetOpt/Generics/ResultSpec.hs +15/−0
• test/System/Console/GetOpt/GenericsSpec.hs +317/−0

@@ -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

@@ -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 <https://github.com/zalora/getopt-generics#getopt-generics README>.+description:    "getopt-generics" tries to make it very simple to create command line argument parsers. An introductory example can be found in the <https://github.com/zalora/getopt-generics#getopt-generics README>. 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

@@ -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

@@ -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 

@@ -0,0 +1,10 @@++module ExamplesSpec where++import           Test.Hspec++import           Example   ()+import           Readme    ()++spec :: Spec+spec = return ()

@@ -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']

@@ -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

@@ -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"]

@@ -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))