getopt-generics 0.10.0.1 → 0.11

raw patch · 59 files changed

+1831/−1439 lines, 59 filesdep +safedep −directorydep −processdep −temporaryPVP ok

version bump matches the API change (PVP)

Dependencies added: safe

Dependencies removed: directory, process, temporary

API changes (from Hackage documentation)

Files

• README.md +49/−0
• docs/CustomOption.hs +21/−0
• docs/CustomOption.shell-protocol +5/−0
• docs/CustomOptionRecord.hs +33/−0
• docs/CustomOptionRecord.shell-protocol +6/−0
• docs/CustomOptionsExample.bash-protocol +0/−5
• docs/CustomOptionsExample.hs +0/−15
• docs/Example.hs +0/−26
• docs/RecordType.hs +26/−0
• docs/RecordType.shell-protocol +16/−0
• docs/RecordTypeExample.bash-protocol +0/−14
• docs/RecordTypeExample.hs +0/−24
• docs/Simple.hs +9/−0
• docs/Simple.shell-protocol +16/−0
• docs/SimpleExample.bash-protocol +0/−7
• docs/SimpleExample.hs +0/−7
• docs/SimpleRecord.hs +24/−0
• docs/SimpleRecord.shell-protocol +16/−0
• docs/Test01.hs +10/−0
• docs/Test01.shell-protocol +7/−0
• docs/Test02.hs +26/−0
• docs/Test02.shell-protocol +21/−0
• docs/Test03.hs +35/−0
• docs/Test03.shell-protocol +7/−0
• docs/Test04.hs +34/−0
• docs/Test04.shell-protocol +7/−0
• getopt-generics.cabal +56/−53
• src/System/Console/GetOpt/Generics.hs +106/−14
• src/System/Console/GetOpt/Generics/FieldString.hs +0/−48
• src/System/Console/GetOpt/Generics/GetArguments.hs +0/−505
• src/System/Console/GetOpt/Generics/Modifier.hs +57/−107
• src/System/Console/GetOpt/Generics/Modifier/Types.hs +20/−0
• src/System/Console/GetOpt/Generics/Result.hs +0/−83
• src/System/Console/GetOpt/Generics/Simple.hs +0/−96
• src/WithCli.hs +118/−0
• src/WithCli/Argument.hs +96/−0
• src/WithCli/Flag.hs +45/−0
• src/WithCli/HasArguments.hs +320/−0
• src/WithCli/Normalize.hs +32/−0
• src/WithCli/Parser.hs +135/−0
• src/WithCli/Result.hs +78/−0
• test/BashProtocol.hs +0/−44
• test/Examples.hs +0/−57
• test/ExamplesSpec.hs +51/−0
• test/ModifiersSpec.hs +5/−7
• test/ModifiersSpec/UseForPositionalArgumentsSpec.hs +14/−1
• test/ShellProtocol.hs +50/−0
• test/System/Console/GetOpt/Generics/FieldStringSpec.hs +0/−79
• test/System/Console/GetOpt/Generics/ModifierSpec.hs +2/−29
• test/System/Console/GetOpt/Generics/ResultSpec.hs +0/−66
• test/System/Console/GetOpt/Generics/SimpleSpec.hs +0/−64
• test/System/Console/GetOpt/GenericsSpec.hs +17/−86
• test/Util.hs +9/−2
• test/WithCli/ArgumentSpec.hs +26/−0
• test/WithCli/HasArgumentsSpec.hs +34/−0
• test/WithCli/NormalizeSpec.hs +63/−0
• test/WithCli/ParserSpec.hs +29/−0
• test/WithCli/ResultSpec.hs +55/−0
• test/WithCliSpec.hs +45/−0

@@ -0,0 +1,49 @@+# getopt-generics++## Status++This library is experimental.++## Usage++`getopt-generics` tries to make it very simple to create command line+interfaces. Here's an example:++<!--- ### Start "docs/Simple.hs" "module Simple where\n\n" (MarkDown Haskell) ### -->++``` haskell+import WithCli++main :: IO ()+main = withCli run++run :: String -> Int -> Bool -> IO ()+run s i b = print (s, i, b)+```++<!--- ### End ### -->++This is how the program behaves in a shell:++<!--- ### Start "docs/Simple.shell-protocol" "" (MarkDown Shell) ### -->++``` shell+$ program foo 42 true+("foo",42,True)+$ program --help+program [OPTIONS] STRING INTEGER BOOL+  -h  --help  show help and exit+$ program foo 42 bar+cannot parse as BOOL: bar+# exit-code 1+$ program+missing argument of type STRING+missing argument of type INTEGER+missing argument of type BOOL+# exit-code 1+$ program foo 42 yes bar+unknown argument: bar+# exit-code 1+```++<!--- ### End ### -->

@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}++module CustomOption where++import WithCli++data File = File FilePath+  deriving (Show, Typeable)++instance Argument File where+  argumentType Proxy = "custom-file-type"+  parseArgument f = Just (File f)++instance HasArguments File where+  argumentsParser = atomicArgumentsParser++main :: IO ()+main = withCli run++run :: File -> IO ()+run = print

@@ -0,0 +1,5 @@+$ program --help+program [OPTIONS] custom-file-type+  -h  --help  show help and exit+$ program some/file+File "some/file"

@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module CustomOptionRecord where++import qualified GHC.Generics+import           WithCli++data File = File FilePath+  deriving (Show, Typeable)++instance Argument File where+  argumentType Proxy = "custom-file-type"+  parseArgument f = Just (File f)++data Options+  = Options {+    file :: File+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic Options+instance HasDatatypeInfo Options+instance HasArguments Options+instance HasArguments File where+  argumentsParser = atomicArgumentsParser++main :: IO ()+main = withCli run++run :: Options -> IO ()+run = print

@@ -0,0 +1,6 @@+$ program --file some/file+Options {file = File "some/file"}+$ program --help+program [OPTIONS]+      --file=custom-file-type+  -h  --help                   show help and exit

@@ -1,5 +0,0 @@-$ program some/file-File "some/file"-$ program --help-program [OPTIONS] custom-file-type-  -h  --help  show help and exit

@@ -1,15 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--import           Data.Typeable-import           System.Console.GetOpt.Generics--data File = File FilePath-  deriving (Show, Typeable)--instance Option File where-  argumentType Proxy = "custom-file-type"-  parseArgument f = Just (File f)--main :: IO ()-main = simpleCLI $ \ file -> do-  print (file :: File)

@@ -1,26 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--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

@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric #-}++module RecordType where++import qualified GHC.Generics+import           System.Console.GetOpt.Generics++-- All you have to do is to define a type and derive some instances:++data Options+  = Options {+    port :: Int,+    daemonize :: Bool,+    config :: Maybe FilePath+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic Options+instance HasDatatypeInfo Options++-- Then you can use `getArguments` to create a command-line argument parser:++main :: IO ()+main = do+  options <- getArguments+  print (options :: Options)

@@ -0,0 +1,16 @@+$ program --port 8080 --config some/path+Options {port = 8080, daemonize = False, config = Just "some/path"}+$ program  --port 8080 --daemonize+Options {port = 8080, daemonize = True, config = Nothing}+$ program --port foo+cannot parse as INTEGER: foo+# exit-code 1+$ program+missing option: --port=INTEGER+# exit-code 1+$ program --help+program [OPTIONS]+      --port=INTEGER+      --daemonize+      --config=STRING (optional)+  -h  --help                      show help and exit

@@ -1,14 +0,0 @@-$ program --port 8080 --config some/path-Options {port = 8080, daemonize = False, config = Just "some/path"}-$ program  --port 8080 --daemonize-Options {port = 8080, daemonize = True, config = Nothing}-$ program --port foo-cannot parse as INTEGER: foo-$ program-missing option: --port=INTEGER-$ program --help-program [OPTIONS]-      --port=INTEGER-      --daemonize-      --config=STRING (optional)-  -h  --help                      show help and exit

@@ -1,24 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--import GHC.Generics-import System.Console.GetOpt.Generics---- All you have to do is to define a type and derive some instances:--data Options-  = Options {-    port :: Int,-    daemonize :: Bool,-    config :: Maybe FilePath-  }-  deriving (Show, GHC.Generics.Generic)--instance System.Console.GetOpt.Generics.Generic Options-instance HasDatatypeInfo Options---- Then you can use `getArguments` to create a command-line argument parser:--main :: IO ()-main = do-  options <- getArguments-  print (options :: Options)

@@ -0,0 +1,9 @@+module Simple where++import WithCli++main :: IO ()+main = withCli run++run :: String -> Int -> Bool -> IO ()+run s i b = print (s, i, b)

@@ -0,0 +1,16 @@+$ program foo 42 true+("foo",42,True)+$ program --help+program [OPTIONS] STRING INTEGER BOOL+  -h  --help  show help and exit+$ program foo 42 bar+cannot parse as BOOL: bar+# exit-code 1+$ program+missing argument of type STRING+missing argument of type INTEGER+missing argument of type BOOL+# exit-code 1+$ program foo 42 yes bar+unknown argument: bar+# exit-code 1

@@ -1,7 +0,0 @@-$ program foo 42 true-("foo",42,True)-$ program foo 42 bar-cannot parse as BOOL: bar-$ program --help-program [OPTIONS] STRING INTEGER BOOL-  -h  --help  show help and exit

@@ -1,7 +0,0 @@-import           System.Console.GetOpt.Generics--main :: IO ()-main = simpleCLI myMain--myMain :: String -> Int -> Bool -> IO ()-myMain s i b = print (s, i, b)

@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveGeneric #-}++module SimpleRecord where++import qualified GHC.Generics+import           System.Console.GetOpt.Generics++data Options+  = Options {+    port :: Int,+    daemonize :: Bool,+    config :: Maybe FilePath+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic Options+instance HasDatatypeInfo Options+instance HasArguments Options++main :: IO ()+main = withCli run++run :: Options -> IO ()+run = print

@@ -0,0 +1,16 @@+$ program --port 8080 --config some/path+Options {port = 8080, daemonize = False, config = Just "some/path"}+$ program  --port 8080 --daemonize+Options {port = 8080, daemonize = True, config = Nothing}+$ program --port foo+cannot parse as INTEGER: foo+# exit-code 1+$ program+missing option: --port=INTEGER+# exit-code 1+$ program --help+program [OPTIONS]+      --port=INTEGER+      --daemonize+      --config=STRING (optional)+  -h  --help                      show help and exit

@@ -0,0 +1,10 @@++module Test01 where++import WithCli++main :: IO ()+main = withCli run++run :: Int -> Bool -> IO ()+run = curry print

@@ -0,0 +1,7 @@+$ program 42+missing argument of type BOOL+# exit-code 1+$ program+missing argument of type INTEGER+missing argument of type BOOL+# exit-code 1

@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Test02 where++import qualified GHC.Generics+import           WithCli++data Options+  = Options {+    port :: Int,+    daemonize :: Bool,+    config :: Maybe FilePath,+    args :: [String]+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic Options+instance HasDatatypeInfo Options+instance HasArguments Options++main :: IO ()+main = withCli run++run :: Options -> IO ()+run = print

@@ -0,0 +1,21 @@+$ program --port 8080 --config some/path+Options {port = 8080, daemonize = False, config = Just "some/path", args = []}+$ program --port 8080 --config some/path --foo true+unrecognized option `--foo'+unknown argument: true+# exit-code 1+$ program  --port 8080 --daemonize --config some+Options {port = 8080, daemonize = True, config = Just "some", args = []}+$ program --port foo+cannot parse as INTEGER: foo+# exit-code 1+$ program+missing option: --port=INTEGER+# exit-code 1+$ program --help+program [OPTIONS]+      --port=INTEGER+      --daemonize+      --config=STRING (optional)+      --args=STRING (multiple possible)+  -h  --help                             show help and exit

@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}++module Test03 where++import qualified GHC.Generics+import           WithCli++main :: IO ()+main = withCli run++run :: (A, B) -> IO ()+run options = do+  print (options :: (A, B))++data A+  = A {+    aa :: String+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic A+instance HasDatatypeInfo A+instance HasArguments A++data B+  = B {+    bb :: String+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic B+instance HasDatatypeInfo B+instance HasArguments B

@@ -0,0 +1,7 @@+$ program --aa foo --bb bar+(A {aa = "foo"},B {bb = "bar"})+$ program --help+program [OPTIONS]+      --aa=STRING+      --bb=STRING+  -h  --help       show help and exit

@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}++module Test04 where++import qualified GHC.Generics+import           WithCli++main :: IO ()+main = withCli run++run :: A -> B -> IO ()+run a b = do+  print (a, b)++data A+  = A {+    aa :: String+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic A+instance HasDatatypeInfo A+instance HasArguments A++data B+  = B {+    bb :: String+  }+  deriving (Show, GHC.Generics.Generic)++instance Generic B+instance HasDatatypeInfo B+instance HasArguments B

@@ -0,0 +1,7 @@+$ program --aa foo --bb bar+(A {aa = "foo"},B {bb = "bar"})+$ program --help+program [OPTIONS]+      --aa=STRING+      --bb=STRING+  -h  --help       show help and exit

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           getopt-generics-version:        0.10.0.1+version:        0.11 synopsis:       Create command line interfaces with ease description:    Create command line interfaces with ease category:       Console, System@@ -18,13 +18,25 @@ cabal-version:  >= 1.10  extra-source-files:-    docs/CustomOptionsExample.bash-protocol-    docs/CustomOptionsExample.hs-    docs/Example.hs-    docs/RecordTypeExample.bash-protocol-    docs/RecordTypeExample.hs-    docs/SimpleExample.bash-protocol-    docs/SimpleExample.hs+    docs/CustomOption.hs+    docs/CustomOption.shell-protocol+    docs/CustomOptionRecord.hs+    docs/CustomOptionRecord.shell-protocol+    docs/RecordType.hs+    docs/RecordType.shell-protocol+    docs/Simple.hs+    docs/Simple.shell-protocol+    docs/SimpleRecord.hs+    docs/SimpleRecord.shell-protocol+    docs/Test01.hs+    docs/Test01.shell-protocol+    docs/Test02.hs+    docs/Test02.shell-protocol+    docs/Test03.hs+    docs/Test03.shell-protocol+    docs/Test04.hs+    docs/Test04.shell-protocol+    README.md  source-repository head   type: git@@ -41,45 +53,17 @@     , generics-sop     , tagged   exposed-modules:+      WithCli       System.Console.GetOpt.Generics   other-modules:-      System.Console.GetOpt.Generics.FieldString-      System.Console.GetOpt.Generics.GetArguments       System.Console.GetOpt.Generics.Modifier-      System.Console.GetOpt.Generics.Result-      System.Console.GetOpt.Generics.Simple-  default-language: Haskell2010--test-suite examples-  type: exitcode-stdio-1.0-  main-is: Examples.hs-  hs-source-dirs:-      test-  ghc-options: -Wall -fno-warn-name-shadowing -threaded -O0-  build-depends:-      base == 4.*-    , base-compat >= 0.8-    , base-orphans-    , generics-sop-    , tagged-    , hspec >= 2.1.8-    , temporary-    , directory-    , filepath-    , process-    , silently-  other-modules:-      BashProtocol-      ModifiersSpec-      ModifiersSpec.RenameOptionsSpec-      ModifiersSpec.UseForPositionalArgumentsSpec-      Spec-      System.Console.GetOpt.Generics.FieldStringSpec-      System.Console.GetOpt.Generics.ModifierSpec-      System.Console.GetOpt.Generics.ResultSpec-      System.Console.GetOpt.Generics.SimpleSpec-      System.Console.GetOpt.GenericsSpec-      Util+      System.Console.GetOpt.Generics.Modifier.Types+      WithCli.Argument+      WithCli.Flag+      WithCli.HasArguments+      WithCli.Normalize+      WithCli.Parser+      WithCli.Result   default-language: Haskell2010  test-suite spec@@ -88,6 +72,7 @@   hs-source-dirs:       src     , test+    , docs   ghc-options: -Wall -fno-warn-name-shadowing -threaded -O0   build-depends:       base == 4.*@@ -98,22 +83,40 @@     , hspec >= 2.1.8     , QuickCheck     , silently+    , filepath+    , safe   other-modules:       System.Console.GetOpt.Generics-      System.Console.GetOpt.Generics.FieldString-      System.Console.GetOpt.Generics.GetArguments       System.Console.GetOpt.Generics.Modifier-      System.Console.GetOpt.Generics.Result-      System.Console.GetOpt.Generics.Simple-      BashProtocol-      Examples+      System.Console.GetOpt.Generics.Modifier.Types+      WithCli+      WithCli.Argument+      WithCli.Flag+      WithCli.HasArguments+      WithCli.Normalize+      WithCli.Parser+      WithCli.Result+      ExamplesSpec       ModifiersSpec       ModifiersSpec.RenameOptionsSpec       ModifiersSpec.UseForPositionalArgumentsSpec-      System.Console.GetOpt.Generics.FieldStringSpec+      ShellProtocol       System.Console.GetOpt.Generics.ModifierSpec-      System.Console.GetOpt.Generics.ResultSpec-      System.Console.GetOpt.Generics.SimpleSpec       System.Console.GetOpt.GenericsSpec       Util+      WithCli.ArgumentSpec+      WithCli.HasArgumentsSpec+      WithCli.NormalizeSpec+      WithCli.ParserSpec+      WithCli.ResultSpec+      WithCliSpec+      CustomOption+      CustomOptionRecord+      RecordType+      Simple+      SimpleRecord+      Test01+      Test02+      Test03+      Test04   default-language: Haskell2010

@@ -1,31 +1,123 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}  module System.Console.GetOpt.Generics (+  -- * Simple IO API+  withCli,+  WithCli(),+  HasArguments,+  WithCli.Argument(argumentType, parseArgument),+  -- * Customizing the CLI+  withCliModified,+  Modifier(..),   -- * IO API-  simpleCLI,-  SimpleCLI,-  ArgumentTypes,   getArguments,   modifiedGetArguments,   -- * Pure API   parseArguments,   Result(..),-  -- * Customizing the CLI-  Modifier(..),-  deriveShortOptions,-  -- * Available Field Types-  Option(argumentType, parseArgument),   -- * Re-exports from "Generics.SOP"-  Generic,+  Generics.SOP.Generic,   HasDatatypeInfo,   Code,   All2,-  SingI,-  Proxy(..),  ) where  import           Generics.SOP+import           System.Environment -import           System.Console.GetOpt.Generics.GetArguments+import           WithCli+import           WithCli.Parser+import           WithCli.HasArguments+import           WithCli.Result import           System.Console.GetOpt.Generics.Modifier-import           System.Console.GetOpt.Generics.Result-import           System.Console.GetOpt.Generics.Simple++-- | Parses command line arguments (gotten from 'withArgs') and returns the+--   parsed value. This function should be enough for simple use-cases.+--+--   Throws the same exceptions as 'withCli'.+--+-- Here's an example:++-- ### Start "docs/RecordType.hs" "" Haddock ###++-- |+-- >  {-# LANGUAGE DeriveGeneric #-}+-- >+-- >  module RecordType where+-- >+-- >  import qualified GHC.Generics+-- >  import           System.Console.GetOpt.Generics+-- >+-- >  -- All you have to do is to define a type and derive some instances:+-- >+-- >  data Options+-- >    = Options {+-- >      port :: Int,+-- >      daemonize :: Bool,+-- >      config :: Maybe FilePath+-- >    }+-- >    deriving (Show, GHC.Generics.Generic)+-- >+-- >  instance Generic Options+-- >  instance HasDatatypeInfo Options+-- >+-- >  -- Then you can use `getArguments` to create a command-line argument parser:+-- >+-- >  main :: IO ()+-- >  main = do+-- >    options <- getArguments+-- >    print (options :: Options)++-- ### End ###++-- | And this is how the above program behaves:++-- ### Start "docs/RecordType.shell-protocol" "" Haddock ###++-- |+-- >  $ program --port 8080 --config some/path+-- >  Options {port = 8080, daemonize = False, config = Just "some/path"}+-- >  $ program  --port 8080 --daemonize+-- >  Options {port = 8080, daemonize = True, config = Nothing}+-- >  $ program --port foo+-- >  cannot parse as INTEGER: foo+-- >  # exit-code 1+-- >  $ program+-- >  missing option: --port=INTEGER+-- >  # exit-code 1+-- >  $ program --help+-- >  program [OPTIONS]+-- >        --port=INTEGER+-- >        --daemonize+-- >        --config=STRING (optional)+-- >    -h  --help                      show help and exit++-- ### End ###++getArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) =>+  IO a+getArguments = modifiedGetArguments []++-- | Like 'getArguments` but allows you to pass in 'Modifier's.+modifiedGetArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) =>+  [Modifier] -> IO a+modifiedGetArguments modifiers = do+  args <- getArgs+  progName <- getProgName+  handleResult $ parseArguments progName modifiers args++-- | Pure variant of 'modifiedGetArguments'.+--+--   Does not throw any exceptions.+parseArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) =>+     String -- ^ Name of the program (e.g. from 'getProgName').+  -> [Modifier] -- ^ List of 'Modifier's to manually tweak the command line interface.+  -> [String] -- ^ List of command line arguments to parse (e.g. from 'getArgs').+  -> Result a+parseArguments progName mods args = do+  modifiers <- mkModifiers mods+  parser <- genericParser modifiers+  runParser progName modifiers+    (normalizeParser (applyModifiers modifiers parser)) args

@@ -1,48 +0,0 @@--module System.Console.GetOpt.Generics.FieldString (-  FieldString,-  mkFieldString,-  normalized,-  matches,-  renameUnnormalized,- ) where--import           Data.Char--data FieldString = FieldString String-  deriving (Show)--normalized :: FieldString -> String-normalized (FieldString s) = normalize s--mkFieldString :: String -> FieldString-mkFieldString = FieldString--matches :: String -> FieldString -> Bool-matches s field =-  normalize s == normalized field--renameUnnormalized :: (String -> Maybe String) -> (FieldString -> FieldString)-renameUnnormalized f input@(FieldString unnormalized) =-  maybe input FieldString (f unnormalized)--normalize :: String -> String-normalize s =-  if all (not . isAllowedChar) s-    then s-    else-      slugify $-      dropWhile (== '-') $-      filter isAllowedChar $-      map (\ c -> if c == '_' then '-' else c) $-      s-  where-    slugify (a : r)-      | isUpper a = slugify (toLower a : r)-    slugify (a : b : r)-      | isUpper b = a : '-' : slugify (toLower b : r)-      | otherwise = a : slugify (b : r)-    slugify x = x--isAllowedChar :: Char -> Bool-isAllowedChar c = (isAscii c && isAlphaNum c) || (c `elem` "-_")

@@ -1,505 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE InstanceSigs          #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE ViewPatterns          #-}--{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}-{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}---- | @getopt-generics@ tries to make it very simple to create command line--- argument parsers.-module System.Console.GetOpt.Generics.GetArguments where--import           Data.Orphans ()-import           Prelude ()-import           Prelude.Compat--import           Data.Char-import           Data.List.Compat-import           Data.Maybe-import           Data.Proxy-import           Data.Typeable-import           Generics.SOP-import           System.Console.GetOpt-import           System.Environment-import           Text.Read.Compat--import           System.Console.GetOpt.Generics.FieldString-import           System.Console.GetOpt.Generics.Modifier-import           System.Console.GetOpt.Generics.Result---- | Parses command line arguments (gotten from 'withArgs') and returns the---   parsed value. This function should be enough for simple use-cases.------   Throws the same exceptions as 'simpleCLI'.------ Here's an example:---- ### Start "docs/RecordTypeExample.hs" Haddock ###---- |--- >  {-# LANGUAGE DeriveGeneric #-}--- >--- >  import GHC.Generics--- >  import System.Console.GetOpt.Generics--- >--- >  -- All you have to do is to define a type and derive some instances:--- >--- >  data Options--- >    = Options {--- >      port :: Int,--- >      daemonize :: Bool,--- >      config :: Maybe FilePath--- >    }--- >    deriving (Show, GHC.Generics.Generic)--- >--- >  instance System.Console.GetOpt.Generics.Generic Options--- >  instance HasDatatypeInfo Options--- >--- >  -- Then you can use `getArguments` to create a command-line argument parser:--- >--- >  main :: IO ()--- >  main = do--- >    options <- getArguments--- >    print (options :: Options)---- ### End ###---- | And this is how the above program behaves:---- ### Start "docs/RecordTypeExample.bash-protocol" Haddock ###---- |--- >  $ program --port 8080 --config some/path--- >  Options {port = 8080, daemonize = False, config = Just "some/path"}--- >  $ program  --port 8080 --daemonize--- >  Options {port = 8080, daemonize = True, config = Nothing}--- >  $ program --port foo--- >  cannot parse as INTEGER: foo--- >  $ program--- >  missing option: --port=INTEGER--- >  $ program --help--- >  program [OPTIONS]--- >        --port=INTEGER--- >        --daemonize--- >        --config=STRING (optional)--- >    -h  --help                      show help and exit---- ### End ###--getArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>-  IO a-getArguments = modifiedGetArguments []---- | Like 'getArguments` but allows you to pass in 'Modifier's.-modifiedGetArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>-  [Modifier] -> IO a-modifiedGetArguments modifiers = do-  args <- getArgs-  progName <- getProgName-  handleResult $ parseArguments progName modifiers args---- | Pure variant of 'modifiedGetArguments'.------   Does not throw any exceptions.-parseArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>-     String -- ^ Name of the program (e.g. from 'getProgName').-  -> [Modifier] -- ^ List of 'Modifier's to manually tweak the command line interface.-  -> [String] -- ^ List of command line arguments to parse (e.g. from 'getArgs').-  -> Result a-parseArguments progName modifiersList args = do-    let modifiers = mkModifiers modifiersList-    case datatypeInfo (Proxy :: Proxy a) of-      ADT typeName _ (constructorInfo :* Nil) ->-        case constructorInfo of-          (Record _ fields) -> processFields progName modifiers args-            (hliftA (Comp . Selector) fields)-          Constructor{} ->-            processFields progName modifiers args (hpure (Comp NoSelector))-          Infix{} ->-            err typeName "infix constructors"-      ADT typeName _ Nil ->-        err typeName "empty data types"-      ADT typeName _ (_ :* _ :* _) ->-        err typeName "sum types"-      Newtype _ _ (Record _ fields) ->-        processFields progName modifiers args-          (hliftA (Comp . Selector) fields)-      Newtype typeName _ (Constructor _) ->-        err typeName "constructors without field labels"-  where-    err typeName message =-      errors ["getopt-generics doesn't support " ++ message ++-              " (" ++ typeName ++ ")."]--data Field a-  = NoSelector-  | Selector a--processFields :: forall a xs .-  (Generic a, Code a ~ '[xs], SingI xs, All Option xs) =>-  String -> Modifiers -> [String] -> NP (Field :.: FieldInfo) xs -> Result a-processFields progName modifiers args fields = do-    initialFieldStates <- mkInitialFieldStates modifiers fields--    showOutputInfo--    let (options, arguments, parseErrors) =-          getOpt Permute (mkOptDescrs modifiers fields) args--    reportGetOptErrors parseErrors--    withPositionalArguments <- fillInPositionalArguments arguments $-      project options initialFieldStates--    to . SOP . Z <$> collectResult withPositionalArguments-  where-    showOutputInfo :: Result ()-    showOutputInfo = outputInfo progName modifiers args fields--    reportGetOptErrors :: [String] -> Result ()-    reportGetOptErrors parseErrors = case parseErrors of-      [] -> pure ()-      errs -> errors errs---- Creates a list of NS where every element corresponds to one field. To be--- used by 'getOpt'.-mkOptDescrs :: forall xs . (SingI xs, All Option xs) =>-  Modifiers -> NP (Field :.: FieldInfo) xs -> [OptDescr (NS FieldState xs)]-mkOptDescrs modifiers =-  mapMaybe toOptDescr . apInjs_NP . hcliftA (Proxy :: Proxy Option) (mkOptDescr modifiers)--newtype OptDescrE a = OptDescrE (Maybe (OptDescr (FieldState a)))--mkOptDescr :: forall a . Option a => Modifiers -> (Field :.: FieldInfo) a -> OptDescrE a-mkOptDescr _modifiers (Comp NoSelector) = OptDescrE Nothing-mkOptDescr modifiers (Comp (Selector (FieldInfo (mkFieldString -> name)))) = OptDescrE $-  if isPositionalArgumentsField modifiers name-    then Nothing-    else Just $ Option-      (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-toOptDescr (Z (OptDescrE Nothing)) = Nothing-toOptDescr (S a) = fmap (fmap S) (toOptDescr a)---- Initializes an NP of empty fields to be filled in later.--- Contains only default values.-mkInitialFieldStates :: forall xs . (SingI xs, All Option xs) =>-  Modifiers -> NP (Field :.: FieldInfo) xs -> Result (NP FieldState xs)-mkInitialFieldStates modifiers fields = case (sing :: Sing xs, fields) of-  (SNil, Nil) -> return Nil-  (SCons, Comp (Selector (FieldInfo (mkFieldString -> name))) :* r) ->-    (:*) <$> inner name <*> mkInitialFieldStates modifiers r-  (SCons, Comp NoSelector :* r) ->-    (:*) <$> Success PositionalArgument <*> mkInitialFieldStates modifiers r-  _ -> uninhabited "mkInitialFieldStates"-- where-  inner :: forall x . Option x => FieldString -> Result (FieldState x)-  inner name = if isPositionalArgumentsField modifiers name-    then case cast (id :: FieldState x -> FieldState x) of-      (Just id' :: Maybe (FieldState [String] -> FieldState x)) ->-        Success $ id' PositionalArguments-      Nothing -> errors-        ["UseForPositionalArguments can only be used " ++-         "for fields of type [String] not " ++-         show (typeOf (impossible "mkInitialFieldStates" :: x))]-    else return $ _emptyOption modifiers name---- * showing output information--data OutputInfoFlag-  = HelpFlag-  | VersionFlag String-  deriving (Eq, Ord)---- 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 ()-outputInfo progName modifiers args fields =-    case (\ (a, b, c) -> (sort a, b, c)) (getOpt Permute options args) of-      ([], _, _) -> return ()-        -- no help or version flag given-      (HelpFlag : _, _, _) -> outputAndExit $-        usageInfo header $-          toOptDescrUnit (mkOptDescrs modifiers fields) ++-          toOptDescrUnit options-      (VersionFlag version : _, _, _) -> outputAndExit $-        progName ++ " version " ++ version ++ "\n"-  where-    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 ()))--    header :: String-    header = unwords $-      progName :-      "[OPTIONS]" :-      positionalArgumentHelp fields ++-      maybe [] (\ t -> ["[" ++ t ++ "]"])-        (getPositionalArgumentType modifiers) ++-      []--positionalArgumentHelp :: (All Option xs) => NP (Field :.: FieldInfo) xs -> [String]-positionalArgumentHelp (p@(Comp NoSelector) :* r) =-  argumentType (toProxy p) : positionalArgumentHelp r-positionalArgumentHelp (_ :* r) = positionalArgumentHelp r-positionalArgumentHelp Nil = []---- Fills in the positional arguments in the NP that already contains the flag--- values. Fills in FieldErrors in case of--- - parse errors and--- - missing positional arguments.--- The returned Either contains errors in case of too many positional arguments.-fillInPositionalArguments :: (All Option xs) =>-  [String] -> NP FieldState xs -> Result (NP FieldState xs)-fillInPositionalArguments args inputFieldStates = do-    let (result, errs) = inner (Just args) inputFieldStates-    either errors return errs-    Success result-  where-    inner :: All Option xs =>-      Maybe [String] -> NP FieldState xs -> (NP FieldState xs, Either [String] ())-    inner arguments fields = case (arguments, fields) of-      (Just arguments, PositionalArguments :* r) ->-        FieldSuccess arguments `cons` inner Nothing r-      (Nothing, PositionalArguments :* r) ->-        FieldErrors ["UseForPositionalArguments can only be used once"] `cons` inner Nothing r--      (Just (argument : arguments), PositionalArgument :* r) ->-        case parseArgumentEither argument of-          Right a -> FieldSuccess a `cons` inner (Just arguments) r-          Left err -> FieldErrors [err] `cons` inner (Just arguments) r-      (Just [], p@PositionalArgument :* r) ->-        FieldErrors ["missing argument of type " ++ argumentType (toProxy p)]-          `cons` inner (Just []) r-      (Nothing, PositionalArgument :* _) ->-        impossible "fillInPositionalArguments"--      (arguments, a :* r) -> a `cons` inner arguments r-      (Just [], Nil) -> (Nil, Right ())-      (Nothing, Nil) -> (Nil, Right ())-      (Just arguments@(_ : _), Nil) ->-        (Nil, Left (map (\ arg -> "unknown argument: " ++ arg) arguments))--    cons :: FieldState x -> (NP FieldState xs, r) -> (NP FieldState (x ': xs), r)-    cons fieldState (arguments, r) = (fieldState :* arguments, r)---- Collects all FieldStates into a Result NP. If any errors are contained they--- will be accumulated.-collectResult :: (SingI xs) => NP FieldState xs -> Result (NP I xs)-collectResult input =-    hsequence $ hliftA inner input-  where-    inner :: FieldState x -> Result x-    inner s = case s of-      FieldSuccess v -> Success v-      FieldErrors errs -> errors errs-      Unset err -> errors [err]-      PositionalArguments -> impossible "collectResult"-      PositionalArgument -> impossible "collectResult"---- * helper functions for NS and NP--project :: (SingI xs, All Option xs) =>-  [NS FieldState xs] -> NP FieldState xs -> NP FieldState xs-project sums start =-    foldl' inner start sums-  where-    inner :: (All Option xs) =>-      NP FieldState xs -> NS FieldState xs -> NP FieldState xs-    inner (a :* r) (Z b) = combine a b :* r-    inner (a :* r) (S rSum) = a :* inner r rSum-    inner Nil _ = uninhabited "project"--impossible :: String -> a-impossible name = error ("System.Console.GetOpt.Generics." ++ name ++ ": This should never happen!")--uninhabited :: String -> a-uninhabited = impossible--toProxy :: f a -> Proxy a-toProxy = const Proxy---- * possible field types--data FieldState a where-  Unset :: String -> FieldState a-  FieldErrors :: [String] -> FieldState a-  FieldSuccess :: a -> FieldState a-  PositionalArguments :: FieldState [String]-  PositionalArgument :: FieldState a-  deriving (Typeable)---- | Type class for all allowed field types.------   If you want to use custom field types you should implement an---   @instance Option YourCustomType@ containing implementations of---   'argumentType' and 'parseArgument' (the minimal complete definition).------ Here's an example:---- ### Start "docs/CustomOptionsExample.hs" Haddock ###---- |--- >  {-# LANGUAGE DeriveDataTypeable #-}--- >--- >  import           Data.Typeable--- >  import           System.Console.GetOpt.Generics--- >--- >  data File = File FilePath--- >    deriving (Show, Typeable)--- >--- >  instance Option File where--- >    argumentType Proxy = "custom-file-type"--- >    parseArgument f = Just (File f)--- >--- >  main :: IO ()--- >  main = simpleCLI $ \ file -> do--- >    print (file :: File)---- ### End ###---- | This would give you:---- ### Start "docs/CustomOptionsExample.bash-protocol" Haddock ###---- |--- >  $ program some/file--- >  File "some/file"--- >  $ program --help--- >  program [OPTIONS] custom-file-type--- >    -h  --help  show help and exit---- ### End ###--class Typeable a => Option a where-  {-# MINIMAL argumentType, parseArgument #-}-  -- | Name of the argument type, e.g. "bool" or "integer".-  argumentType :: Proxy a -> String--  -- | Parses a 'String' into an argument. Returns 'Nothing' on parse errors.-  parseArgument :: String -> Maybe a--  -- | This is meant to be an internal function.-  _toOption :: ArgDescr (FieldState a)-  _toOption = ReqArg parseAsFieldState (argumentType (Proxy :: Proxy a))--  -- | This is meant to be an internal function.-  _emptyOption :: Modifiers -> FieldString -> FieldState a-  _emptyOption modifiers flagName = Unset-    ("missing option: --" ++ mkLongOption modifiers flagName ++-     "=" ++ argumentType (Proxy :: Proxy a))--  -- | This is meant to be an internal function.-  _accumulate :: a -> a -> a-  _accumulate _ x = x--parseArgumentEither :: forall a . Option a => String -> Either String a-parseArgumentEither s =-  maybe-    (Left ("cannot parse as " ++ argumentType (Proxy :: Proxy a) ++ ": " ++ s))-    Right-    (parseArgument s)--parseAsFieldState :: forall a . Option a => String -> FieldState a-parseAsFieldState s = either-  (\ err -> FieldErrors [err])-  FieldSuccess-  (parseArgumentEither s)--combine :: Option a => FieldState a -> FieldState a -> FieldState a-combine _ (Unset _) = impossible "combine"-combine _ PositionalArguments = impossible "combine"-combine _ PositionalArgument = impossible "combine"-combine (FieldErrors e) (FieldErrors f) = FieldErrors (e ++ f)-combine (FieldErrors e) _ = FieldErrors e-combine (Unset _) x = x-combine (FieldSuccess _) (FieldErrors e) = FieldErrors e-combine (FieldSuccess a) (FieldSuccess b) = FieldSuccess (_accumulate a b)-combine PositionalArguments _ = PositionalArguments-combine PositionalArgument _ = PositionalArgument--instance Option a => Option [a] where-  argumentType Proxy = argumentType (Proxy :: Proxy a) ++ " (multiple possible)"-  parseArgument x = case parseArgument x of-    Just (x :: a) -> Just [x]-    Nothing -> Nothing-  _emptyOption _ _ = FieldSuccess []-  _accumulate = (++)--instance Option a => Option (Maybe a) where-  argumentType Proxy = argumentType (Proxy :: Proxy a) ++ " (optional)"-  parseArgument x = case parseArgument x of-    Just (x :: a) -> Just (Just x)-    Nothing -> Nothing-  _emptyOption _ _ = FieldSuccess Nothing--instance Option Bool where-  argumentType _ = "BOOL"--  parseArgument :: String -> Maybe Bool-  parseArgument s-    | map toLower s `elem` ["true", "yes", "on"] = Just True-    | map toLower s `elem` ["false", "no", "off"] = Just False-    | otherwise = case readMaybe s of-      Just (n :: Integer) -> Just (n > 0)-      Nothing -> Nothing--  _toOption = NoArg (FieldSuccess True)-  _emptyOption _ _ = FieldSuccess False--instance Option String where-  argumentType Proxy = "STRING"-  parseArgument = Just--instance Option Int where-  argumentType _ = "INTEGER"-  parseArgument = readMaybe--instance Option Integer where-  argumentType _ = "INTEGER"-  parseArgument = readMaybe--readNumber :: (RealFloat n, Read n) => String -> Maybe n-readNumber s = case readMaybe s of-  Just n -> Just n-  Nothing-    | "." `isPrefixOf` s -> readMaybe ("0" ++ s)-    | otherwise -> Nothing--instance Option Float where-  argumentType _ = "NUMBER"-  parseArgument = readNumber--instance Option Double where-  argumentType _ = "NUMBER"-  parseArgument = readNumber

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs            #-}+{-# LANGUAGE LambdaCase       #-} {-# LANGUAGE TupleSections    #-} {-# LANGUAGE ViewPatterns     #-} @@ -7,30 +8,31 @@   Modifier(..),   Modifiers,   mkModifiers,-  mkShortOptions,-  mkLongOption,-  hasPositionalArgumentsField,   isPositionalArgumentsField,   getPositionalArgumentType,-  getHelpText,   getVersion, -  deriveShortOptions,+  applyModifiers,+  applyModifiersLong,    -- exported for testing-  mkShortModifiers,   insertWith,  ) where  import           Prelude () import           Prelude.Compat +import           Control.Arrow+import           Control.Monad import           Data.Char-import           Data.List (find, foldl')+import           Data.List (foldl') import           Data.Maybe-import           Generics.SOP+import           System.Console.GetOpt -import           System.Console.GetOpt.Generics.FieldString+import           System.Console.GetOpt.Generics.Modifier.Types+import           WithCli.Parser+import           WithCli.Normalize+import           WithCli.Result  -- | 'Modifier's can be used to customize the command line parser. data Modifier@@ -59,116 +61,34 @@   | AddVersionFlag String     -- ^ @AddVersionFlag version@ adds a @--version@ flag. -data Modifiers = Modifiers {-  _shortOptions :: [(String, [Char])],-  _renaming :: FieldString -> FieldString,-  positionalArgumentsField :: [(String, String)],-  helpTexts :: [(String, String)],-  version :: Maybe String- }--mkModifiers :: [Modifier] -> Modifiers-mkModifiers = foldl' inner empty+mkModifiers :: [Modifier] -> Result Modifiers+mkModifiers = foldM inner empty   where     empty :: Modifiers-    empty = Modifiers [] id [] [] Nothing+    empty = Modifiers [] id Nothing [] Nothing -    inner :: Modifiers -> Modifier -> Modifiers+    inner :: Modifiers -> Modifier -> Result Modifiers     inner (Modifiers shorts renaming args help version) modifier = case modifier of       (AddShortOption option short) ->-        Modifiers (insertWith (++) option [short] shorts) renaming args help version+        return $ Modifiers (insertWith (++) option [short] shorts) renaming args help version       (RenameOption from to) ->-        let newRenaming :: FieldString -> FieldString+        let newRenaming :: String -> String             newRenaming option = if from `matches` option-              then mkFieldString to+              then to               else option-        in Modifiers shorts (renaming . newRenaming) args help version+        in return $ Modifiers shorts (renaming . newRenaming) args help version       (RenameOptions newRenaming) ->-        Modifiers shorts (renaming `combineRenamings` newRenaming) args help version-      (UseForPositionalArguments option typ) ->-        Modifiers shorts renaming ((option, map toUpper typ) : args) help version+        return $ Modifiers shorts (renaming `combineRenamings` newRenaming) args help version+      (UseForPositionalArguments option typ) -> case args of+        Nothing -> return $ Modifiers shorts renaming (Just (option, map toUpper typ)) help version+        Just _ -> Errors ["UseForPositionalArguments can only be used once"]       (AddOptionHelp option helpText) ->-        Modifiers shorts renaming args (insert option helpText help) version+        return $ Modifiers shorts renaming args (insert option helpText help) version       (AddVersionFlag v) ->-        Modifiers shorts renaming args help (Just v)--    combineRenamings :: (FieldString -> FieldString) -> (String -> Maybe String)-      -> FieldString -> FieldString-    combineRenamings old new fieldString =-      (old . renameUnnormalized new) fieldString--lookupMatching :: [(String, a)] -> FieldString -> Maybe a-lookupMatching list option = fmap snd $ find (\ (from, _) -> from `matches` option) list--mkShortOptions :: Modifiers -> FieldString -> [Char]-mkShortOptions (Modifiers shortMap _ _ _ _) option = fromMaybe [] (lookupMatching shortMap option)--mkLongOption :: Modifiers -> FieldString -> String-mkLongOption (Modifiers _ renaming _ _ _) option =-  normalized (renaming option)--hasPositionalArgumentsField :: Modifiers -> Bool-hasPositionalArgumentsField = not . null . positionalArgumentsField--isPositionalArgumentsField :: Modifiers -> FieldString -> Bool-isPositionalArgumentsField modifiers field =-  any (`matches` field) (map fst (positionalArgumentsField modifiers))--getPositionalArgumentType :: Modifiers -> Maybe String-getPositionalArgumentType = fmap snd . listToMaybe . positionalArgumentsField--getHelpText :: Modifiers -> FieldString -> String-getHelpText modifiers field = fromMaybe "" $ lookupMatching (helpTexts modifiers) field--getVersion :: Modifiers -> Maybe String-getVersion modifiers = version modifiers---- * deriving Modifiers---- | Derives 'AddShortOption's for all fields of the datatype that start with a---   unique character.-deriveShortOptions :: (HasDatatypeInfo a, SingI (Code a)) =>-  Proxy a -> [Modifier]-deriveShortOptions proxy =-  mkShortModifiers (flags proxy)--flags :: (SingI (Code a), HasDatatypeInfo a) =>-  Proxy a -> [String]-flags proxy = case datatypeInfo proxy of-    ADT _ _ ci -> fromNPConstructorInfo ci-    Newtype _ _ ci -> fromConstructorInfo ci-  where-    fromNPConstructorInfo :: NP ConstructorInfo xs -> [String]-    fromNPConstructorInfo Nil = []-    fromNPConstructorInfo (a :* r) =-      fromConstructorInfo a ++ fromNPConstructorInfo r--    fromConstructorInfo :: ConstructorInfo x -> [String]-    fromConstructorInfo (Constructor _) = []-    fromConstructorInfo (Infix _ _ _) = []-    fromConstructorInfo (Record _ fields) =-      fromFields fields--    fromFields :: NP FieldInfo xs -> [String]-    fromFields (FieldInfo name :* r) = name : fromFields r-    fromFields Nil = []+        return $ Modifiers shorts renaming args help (Just v) -mkShortModifiers :: [String] -> [Modifier]-mkShortModifiers fields =-    let withShorts = mapMaybe (\ field -> (field, ) <$> toShort field) fields-        allShorts = map snd withShorts-        isUnique c = case filter (== c) allShorts of-          [_] -> True-          _ -> False-    in (flip mapMaybe) withShorts $ \ (field, short) ->-          if isUnique short-            then Just (AddShortOption field short)-            else Nothing-  where-    toShort :: String -> Maybe Char-    toShort s = case dropWhile (\ c -> not (isAscii c && isAlpha c)) s of-      [] -> Nothing-      (a : _) -> Just (toLower a)+    combineRenamings :: (a -> a) -> (a -> Maybe a) -> (a -> a)+    combineRenamings old new x = old (fromMaybe x (new x))  -- * list utils to replace Data.Map @@ -185,3 +105,33 @@   if a == key     then (key, value) : r     else (a, b) : insert key value r++-- * transforming Parsers++applyModifiers :: Modifiers -> Parser Unnormalized a -> Parser Unnormalized a+applyModifiers modifiers =+  addShortOptions >>>+  renameOptions+  where+    addShortOptions = modParserOptions $ map $+      \ option ->+        case filter (\ (needle, _) -> needle `elem` longs option) (shortOptions modifiers) of+          [] -> option+          (concat . map snd -> newShorts) ->+            foldl' (flip addShort) option newShorts+    renameOptions =+      modParserOptions $ map $ modLongs $ renaming modifiers++applyModifiersLong :: Modifiers -> String -> String+applyModifiersLong modifiers long = (renaming modifiers) long++longs :: OptDescr a -> [String]+longs (Option _ ls _ _) = ls++addShort :: Char -> OptDescr a -> OptDescr a+addShort short (Option shorts longs argDescrs help) =+  Option (shorts ++ [short]) longs argDescrs help++modLongs :: (String -> String) -> OptDescr a -> OptDescr a+modLongs f (Option shorts longs descrs help) =+  Option shorts (map f longs) descrs help

@@ -0,0 +1,20 @@++module System.Console.GetOpt.Generics.Modifier.Types where++data Modifiers = Modifiers {+  shortOptions :: [(String, [Char])],+  renaming :: String -> String,+  positionalArgumentsField :: Maybe (String, String),+  _helpTexts :: [(String, String)],+  version :: Maybe String+ }++getVersion :: Modifiers -> Maybe String+getVersion modifiers = version modifiers++isPositionalArgumentsField :: Modifiers -> String -> Bool+isPositionalArgumentsField modifiers field =+  maybe False ((field ==) . fst) (positionalArgumentsField modifiers)++getPositionalArgumentType :: Modifiers -> Maybe String+getPositionalArgumentType = fmap snd . positionalArgumentsField

@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--module System.Console.GetOpt.Generics.Result (-  Result(..),-  errors,-  outputAndExit,-  handleResult,- ) where--import           Prelude ()-import           Prelude.Compat--import           Data.List-import           System.Exit-import           System.IO---- | Type to wrap results from the pure parsing functions.-data Result a-  = Success a-    -- ^ The CLI was used correctly and a value of type @a@ was-    --   successfully constructed.-  | Errors [String]-    -- ^ The CLI was used incorrectly. The 'Result' contains a list of error-    --   messages.-    ---    --   It can also happen that the data type you're trying to use isn't-    --   supported. See the-    --   <https://github.com/zalora/getopt-generics#getopt-generics README> for-    --   details.-  | OutputAndExit String-    -- ^ The CLI was used with @--help@. The 'Result' contains the help message.-  deriving (Show, Eq, Ord, Functor)--errors :: [String] -> Result a-errors = Errors . map removeTrailingNewline--outputAndExit :: String -> Result a-outputAndExit = OutputAndExit . stripTrailingSpaces--instance Applicative Result where-  pure = Success-  OutputAndExit message <*> _ = OutputAndExit message-  _ <*> OutputAndExit message = OutputAndExit message-  Success f <*> Success x = Success (f x)-  Errors a <*> Errors b = Errors (a ++ b)-  Errors errs <*> Success _ = Errors errs-  Success _ <*> Errors errs = Errors errs--instance Monad Result where-  return = pure-  Success a >>= b = b a-  Errors errs >>= _ = Errors errs-  OutputAndExit message >>= _ = OutputAndExit message--  (>>) = (*>)--handleResult :: Result a -> IO a-handleResult result = case result of-  Success a -> return a-  OutputAndExit message -> do-    putStr message-    exitWith ExitSuccess-  Errors errs -> do-    mapM_ (hPutStr stderr . addNewlineIfMissing) errs-    exitWith $ ExitFailure 1--addNewlineIfMissing :: String -> String-addNewlineIfMissing s-  | "\n" `isSuffixOf` s = s-  | otherwise = s ++ "\n"--removeTrailingNewline :: String -> String-removeTrailingNewline s-  | "\n" `isSuffixOf` s = init s-  | otherwise = s--stripTrailingSpaces :: String -> String-stripTrailingSpaces = reverse . inner . dropWhile (== ' ') . reverse-  where-    inner s = case s of-      ('\n' : ' ' : r) -> inner ('\n' : r)-      (a : r) -> a : inner r-      [] -> []

@@ -1,96 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}--module System.Console.GetOpt.Generics.Simple where--import           Generics.SOP-import           System.Environment--import           System.Console.GetOpt.Generics.GetArguments-import           System.Console.GetOpt.Generics.Modifier-import           System.Console.GetOpt.Generics.Result--class SingI (ArgumentTypes main) => SimpleCLI main where-  {-# MINIMAL _initialFieldStates, _run #-}-  type ArgumentTypes main :: [*]-  _initialFieldStates :: Proxy main -> NP FieldState (ArgumentTypes main)-  _run :: NP I (ArgumentTypes main) -> main -> IO ()---- | 'simpleCLI' converts an IO operation into a program with a proper CLI.---   Retrieves command line arguments through 'withArgs'.---   @main@ (the given IO operation) can have arbitrarily many parameters---   provided all parameters have an instance for 'Option'.------   May throw the following exceptions:------   - @'ExitFailure' 1@ in case of invalid options. Error messages are written---     to @stderr@.---   - @'ExitSuccess'@ in case @--help@ is given. (@'ExitSuccess'@ behaves like---     a normal exception, except that -- if uncaught -- the process will exit---     with exit-code @0@.) Help output is written to @stdout@.------   Example:---- ### Start "docs/SimpleExample.hs" Haddock ###---- |--- >  import           System.Console.GetOpt.Generics--- >--- >  main :: IO ()--- >  main = simpleCLI myMain--- >--- >  myMain :: String -> Int -> Bool -> IO ()--- >  myMain s i b = print (s, i, b)---- ### End ###---- | Using the above program in bash:---- ### Start "docs/SimpleExample.bash-protocol" Haddock ###---- |--- >  $ program foo 42 true--- >  ("foo",42,True)--- >  $ program foo 42 bar--- >  cannot parse as BOOL: bar--- >  $ program --help--- >  program [OPTIONS] STRING INTEGER BOOL--- >    -h  --help  show help and exit---- ### End ###--simpleCLI :: forall main . (SimpleCLI main, All Option (ArgumentTypes main)) =>-  main -> IO ()-simpleCLI main = do-  args <- getArgs-  progName <- getProgName-  let result = do-        outputInfo progName (mkModifiers []) args-          (hliftA (const $ Comp NoSelector) (_initialFieldStates (Proxy :: Proxy main)))-        filledIn <- fillInPositionalArguments args (_initialFieldStates (Proxy :: Proxy main))-        collectResult filledIn-  f <- handleResult result-  _run f main--instance SimpleCLI (IO ()) where-  type ArgumentTypes (IO ()) = '[]-  _initialFieldStates Proxy = Nil-  _run Nil = id-  _run _ = impossible "_run"--instance (Option a, SimpleCLI rest) =>-  SimpleCLI (a -> rest) where-    type ArgumentTypes (a -> rest) = a ': ArgumentTypes rest-    _initialFieldStates Proxy = PositionalArgument :* _initialFieldStates (Proxy :: Proxy rest)-    _run (I a :* r) main = _run r (main a)-    _run _ _ = impossible "_run"

@@ -0,0 +1,118 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module WithCli (+  withCli,+  WithCli(),+  HasArguments(argumentsParser),+  atomicArgumentsParser,+  Argument(argumentType, parseArgument),+  -- * Modifiers+  withCliModified,+  Modifier(..),+  -- * Useful Re-exports+  SOP.Generic,+  SOP.HasDatatypeInfo,+  SOP.Code,+  SOP.All2,+  Typeable,+  Proxy(..),+  ) where++-- todo: add pure api with withCli++import           Data.Proxy+import           Data.Typeable+import qualified Generics.SOP as SOP+import           System.Environment++import           System.Console.GetOpt.Generics.Modifier+import           WithCli.Argument+import           WithCli.HasArguments+import           WithCli.Parser+import           WithCli.Result++-- | 'withCli' converts an IO operation into a program with a proper CLI.+--   Retrieves command line arguments through 'withArgs'.+--   @main@ (the given IO operation) can have arbitrarily many parameters+--   provided all parameters have instances for 'HasArguments'.+--+--   May throw the following exceptions:+--+--   - @'ExitFailure' 1@ in case of invalid options. Error messages are written+--     to @stderr@.+--   - @'ExitSuccess'@ in case @--help@ is given. (@'ExitSuccess'@ behaves like+--     a normal exception, except that -- if uncaught -- the process will exit+--     with exit-code @0@.) Help output is written to @stdout@.+--+--   Example:++-- ### Start "docs/Simple.hs" "module Simple where\n\n" Haddock ###++-- |+-- >  import WithCli+-- >+-- >  main :: IO ()+-- >  main = withCli run+-- >+-- >  run :: String -> Int -> Bool -> IO ()+-- >  run s i b = print (s, i, b)++-- ### End ###++-- | Using the above program in a shell:++-- ### Start "docs/Simple.shell-protocol" "" Haddock ###++-- |+-- >  $ program foo 42 true+-- >  ("foo",42,True)+-- >  $ program --help+-- >  program [OPTIONS] STRING INTEGER BOOL+-- >    -h  --help  show help and exit+-- >  $ program foo 42 bar+-- >  cannot parse as BOOL: bar+-- >  # exit-code 1+-- >  $ program+-- >  missing argument of type STRING+-- >  missing argument of type INTEGER+-- >  missing argument of type BOOL+-- >  # exit-code 1+-- >  $ program foo 42 yes bar+-- >  unknown argument: bar+-- >  # exit-code 1++-- ### End ###++withCli :: forall main . WithCli main => main -> IO ()+withCli = withCliModified []++-- | This is a variant of 'withCli' that allows to tweak the generated+--   command line interface by providing a list of 'Modifier's.+withCliModified :: forall main . WithCli main => [Modifier] -> main -> IO ()+withCliModified mods main = do+  args <- getArgs+  modifiers <- handleResult (mkModifiers mods)+  _run modifiers (return $ emptyParser ()) (\ () -> main) args++-- | Everything that can be used as a @main@ function with 'withCli' needs to+--   have an instance of 'WithCli'. You shouldn't need to implement your own+--   instances.+class WithCli main where+  _run :: Modifiers -> Result (Parser Unnormalized a) -> (a -> main) -> [String] -> IO ()++instance WithCli (IO ()) where+  _run modifiers mkParser mkMain args = do+    progName <- getProgName+    parser <- handleResult mkParser+    a <- handleResult $ runParser progName modifiers+      (normalizeParser (applyModifiers modifiers parser)) args+    mkMain a++instance (HasArguments a, WithCli rest) => WithCli (a -> rest) where+  _run modifiers fa mkMain args =+    _run modifiers (combine fa (argumentsParser modifiers Nothing)) (\ (a, r) -> mkMain a r) args

@@ -0,0 +1,96 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverlappingInstances  #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}++module WithCli.Argument where++import           Data.Orphans ()+import           Prelude ()+import           Prelude.Compat++import           Data.List+import           Data.Proxy+import           Text.Read++-- | 'Argument' is a typeclass for things that can be parsed as atomic values from+--   single command line arguments, e.g. strings (and filenames) and numbers.+--+--   Occasionally you might want to declare your own instance for additional+--   type safety and for providing a more informative command argument type.+--   Here's an example:++-- ### Start "docs/CustomOption.hs" "module CustomOption where\n\n" Haddock ###++-- |+-- >  {-# LANGUAGE DeriveDataTypeable #-}+-- >+-- >  import WithCli+-- >+-- >  data File = File FilePath+-- >    deriving (Show, Typeable)+-- >+-- >  instance Argument File where+-- >    argumentType Proxy = "custom-file-type"+-- >    parseArgument f = Just (File f)+-- >+-- >  instance HasArguments File where+-- >    argumentsParser = atomicArgumentsParser+-- >+-- >  main :: IO ()+-- >  main = withCli run+-- >+-- >  run :: File -> IO ()+-- >  run = print++-- ### End ###++-- | And this is how the above program behaves:++-- ### Start "docs/CustomOption.shell-protocol" "" Haddock ###++-- |+-- >  $ program --help+-- >  program [OPTIONS] custom-file-type+-- >    -h  --help  show help and exit+-- >  $ program some/file+-- >  File "some/file"++-- ### End ###++class Argument a where+  argumentType :: Proxy a -> String+  parseArgument :: String -> Maybe a++instance Argument String where+  argumentType Proxy = "STRING"+  parseArgument = Just++instance Argument Int where+  argumentType _ = "INTEGER"+  parseArgument = readMaybe++instance Argument Integer where+  argumentType _ = "INTEGER"+  parseArgument = readMaybe++instance Argument Float where+  argumentType _ = "NUMBER"+  parseArgument = readFloat++instance Argument Double where+  argumentType _ = "NUMBER"+  parseArgument = readFloat++readFloat :: (RealFloat n, Read n) => String -> Maybe n+readFloat s = case readMaybe s of+  Just n -> Just n+  Nothing+    | "." `isPrefixOf` s -> readMaybe ("0" ++ s)+    | otherwise -> Nothing

@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveFunctor #-}++module WithCli.Flag where++import           Prelude ()+import           Prelude.Compat++import           Data.Monoid+import           System.Console.GetOpt++data Flag a+  = Help+  | Version String+  | NoHelp a+  deriving (Functor)++instance Monoid a => Monoid (Flag a) where+  mappend a b = case (a, b) of+    (Help, _) -> Help+    (_, Help) -> Help+    (Version s, _) -> Version s+    (_, Version s) -> Version s+    (NoHelp a, NoHelp b) -> NoHelp (a <> b)+  mempty = NoHelp mempty++foldFlags :: [Flag a] -> Flag [a]+foldFlags flags = mconcat $ map (fmap pure) flags++helpOption :: OptDescr (Flag a)+helpOption =+  Option ['h'] ["help"] (NoArg Help) "show help and exit"++versionOption :: String -> OptDescr (Flag a)+versionOption version =+  Option ['v'] ["version"] (NoArg (Version version)) "show version and exit"++usage :: String -> [String] -> [OptDescr ()] -> String+usage progName fields options = usageInfo header options+  where+    header :: String+    header = unwords $+      progName :+      "[OPTIONS]" :+       fields +++      []

@@ -0,0 +1,320 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}++module WithCli.HasArguments where++import           Data.Orphans ()+import           Prelude ()+import           Prelude.Compat++import           Data.Char+import           Data.List.Compat+import           Data.Proxy+import           Data.Traversable+import           Generics.SOP as SOP+import           System.Console.GetOpt+import           Text.Read++import           System.Console.GetOpt.Generics.Modifier+import           WithCli.Parser+import           WithCli.Normalize+import           WithCli.Argument+import           WithCli.Result++parseArgumentResult :: forall a . Argument a => Maybe String -> String -> Result a+parseArgumentResult mMsg s = case parseArgument s of+  Just x -> return x+  Nothing -> parseError (argumentType (Proxy :: Proxy a)) mMsg s++parseError :: String -> Maybe String -> String -> Result a+parseError typ mMsg s = Errors $ pure $+  "cannot parse as " ++ typ +++  maybe "" (\ msg -> " (" ++ msg ++ ")") mMsg +++  ": " ++ s++-- | Everything that can be used as an argument to your @main@ function+--   (see 'withCli') needs to have a 'HasArguments' instance.+--+--   'HasArguments' also allows to conjure up instances for record types+--   to create more complex command line interfaces. Here's an example:++-- ### Start "docs/SimpleRecord.hs" "module SimpleRecord where\n\n" Haddock ###++-- |+-- >  {-# LANGUAGE DeriveGeneric #-}+-- >+-- >  import qualified GHC.Generics+-- >  import           System.Console.GetOpt.Generics+-- >+-- >  data Options+-- >    = Options {+-- >      port :: Int,+-- >      daemonize :: Bool,+-- >      config :: Maybe FilePath+-- >    }+-- >    deriving (Show, GHC.Generics.Generic)+-- >+-- >  instance Generic Options+-- >  instance HasDatatypeInfo Options+-- >  instance HasArguments Options+-- >+-- >  main :: IO ()+-- >  main = withCli run+-- >+-- >  run :: Options -> IO ()+-- >  run = print++-- ### End ###++-- | In a shell this program behaves like this:++-- ### Start "docs/SimpleRecord.shell-protocol" "" Haddock ###++-- |+-- >  $ program --port 8080 --config some/path+-- >  Options {port = 8080, daemonize = False, config = Just "some/path"}+-- >  $ program  --port 8080 --daemonize+-- >  Options {port = 8080, daemonize = True, config = Nothing}+-- >  $ program --port foo+-- >  cannot parse as INTEGER: foo+-- >  # exit-code 1+-- >  $ program+-- >  missing option: --port=INTEGER+-- >  # exit-code 1+-- >  $ program --help+-- >  program [OPTIONS]+-- >        --port=INTEGER+-- >        --daemonize+-- >        --config=STRING (optional)+-- >    -h  --help                      show help and exit++-- ### End ###++class HasArguments a where+  argumentsParser :: Modifiers -> Maybe String -> Result (Parser Unnormalized a)+  default argumentsParser ::+    (SOP.Generic a, SOP.HasDatatypeInfo a, All2 HasArguments (Code a)) =>+    Modifiers ->+    Maybe String -> Result (Parser Unnormalized a)+  argumentsParser = const . genericParser++-- * atomic HasArguments++instance HasArguments Int where+  argumentsParser = atomicArgumentsParser++instance HasArguments Bool where+  argumentsParser = wrapForPositionalArguments "Bool" (const boolParser)++instance HasArguments String where+  argumentsParser = atomicArgumentsParser++instance HasArguments Float where+  argumentsParser = atomicArgumentsParser++instance HasArguments Double where+  argumentsParser = atomicArgumentsParser++instance (HasArguments a, HasArguments b) => HasArguments (a, b)++instance (HasArguments a, HasArguments b, HasArguments c) => HasArguments (a, b, c)++wrapForPositionalArguments :: String -> (Modifiers -> Maybe String -> Result a) -> (Modifiers -> Maybe String -> Result a)+wrapForPositionalArguments typ wrapped modifiers (Just field) =+  if isPositionalArgumentsField modifiers field+    then Errors ["UseForPositionalArguments can only be used for fields of type [String] not " ++ typ]+    else wrapped modifiers (Just field)+wrapForPositionalArguments _ wrapped modifiers Nothing = wrapped modifiers Nothing++instance Argument a => HasArguments (Maybe a) where+  argumentsParser _ = maybeParser++instance Argument a => HasArguments [a] where+  argumentsParser modifiers (Just field) =+    return $ if isPositionalArgumentsField modifiers field+      then positionalArgumentsParser+      else listParser (Just field)+  argumentsParser _ Nothing =+    return $ listParser Nothing++-- | Useful for implementing your own instances of 'HasArguments' on top+--   of a custom 'Argument' instance.+atomicArgumentsParser :: forall a . Argument a =>+  Modifiers ->+  Maybe String -> Result (Parser Unnormalized a)+atomicArgumentsParser =+  wrapForPositionalArguments typ inner+  where+    typ = argumentType (Proxy :: Proxy a)++    inner modifiers mLong = return $ case mLong of+      Nothing -> withoutLongOption+      Just long -> withLongOption modifiers long++    withoutLongOption = Parser {+      parserDefault = Nothing,+      parserOptions = [],+      parserNonOptions =+        [NonOptionsParser typ (\ (s : r) -> fmap ((, r) . const . Just) $ parseArgumentResult Nothing s)],+      parserConvert = \ case+        Just a -> return a+        Nothing -> Errors $ pure $+          "missing argument of type " ++ typ+    }++    withLongOption modifiers long = Parser {+      parserDefault = Left (),+      parserOptions = pure $+        Option [] [long]+          (fmap (fmap (const . Right)) $+            ReqArg (parseArgumentResult Nothing) typ)+          "",+      parserNonOptions = [],+      parserConvert = \ case+        Right a -> return a+        Left () -> Errors $ pure $+          "missing option: --" ++ normalize (applyModifiersLong modifiers long) ++ "=" ++ typ+    }++listParser :: forall a . Argument a =>+  Maybe String -> Parser Unnormalized [a]+listParser mLong = case mLong of+  Nothing -> positionalArgumentsParser+  Just long -> Parser {+    parserDefault = [],+    parserOptions = pure $+      Option [] [long]+        (ReqArg+          (\ s -> fmap (\ a -> (++ [a])) (parseArgumentResult (Just "multiple possible") s))+          (argumentType (Proxy :: Proxy a) ++ " (multiple possible)"))+        "",+    parserNonOptions = [],+    parserConvert = return+  }++positionalArgumentsParser :: forall a . Argument a =>+  Parser Unnormalized [a]+positionalArgumentsParser = Parser {+  parserDefault = [],+  parserOptions = [],+  parserNonOptions = [NonOptionsParser (argumentType (Proxy :: Proxy a)) parse],+  parserConvert = return+}+  where+    parse :: [String] -> Result ([a] -> [a], [String])+    parse args = do+      mods <- forM args $ \ arg ->+        case parseArgument arg of+          Just a -> return (a :)+          Nothing -> parseError (argumentType (Proxy :: Proxy a)) Nothing arg+      return (foldl' (.) id mods, [])++maybeParser :: forall a . Argument a =>+  Maybe String -> Result (Parser Unnormalized (Maybe a))+maybeParser mLong = case mLong of+  Nothing -> Errors ["cannot use Maybes for positional arguments"]+  Just long -> return $ Parser {+    parserDefault = Nothing,+    parserOptions = pure $+      Option [] [long]+        (ReqArg+          (\ s -> fmap (\ a -> (const (Just a))) (parseArgumentResult (Just "optional") s))+          (argumentType (Proxy :: Proxy a) ++ " (optional)"))+        "",+    parserNonOptions = [],+    parserConvert = return+  }++boolParser :: Maybe String -> Result (Parser Unnormalized Bool)+boolParser mLong = return $ case mLong of+  Nothing -> Parser {+    parserDefault = Nothing,+    parserOptions = [],+    parserNonOptions = pure $+      (NonOptionsParser "BOOL" (\ (s : r) -> (, r) <$> maybe (parseError "BOOL" Nothing s) (return . const . Just) (parseBool s))),+    parserConvert = \ case+      Just x -> return x+      Nothing -> Errors $ pure $+        "missing argument of type BOOL"+  }+  Just long -> Parser {+    parserDefault = False,+    parserOptions = pure $+      Option [] [long]+        (NoArg (return (const True)))+        "",+    parserNonOptions = [],+    parserConvert = return+  }++parseBool :: String -> Maybe Bool+parseBool s+  | map toLower s `elem` ["true", "yes", "on"] = Just True+  | map toLower s `elem` ["false", "no", "off"] = Just False+  | otherwise = case readMaybe s of+    Just (n :: Integer) -> Just (n > 0)+    Nothing -> Nothing++-- * generic HasArguments++genericParser :: forall a .+  (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) =>+  Modifiers ->+  Result (Parser Unnormalized a)+genericParser modifiers = fmap (fmap to) $ case datatypeInfo (Proxy :: Proxy a) of+  ADT _ typeName (constructorInfo :* Nil) ->+    case constructorInfo of+      (Record _ fields) ->+        fmap (fmap (SOP . Z)) (fieldsParser modifiers fields)+      Constructor{} ->+        fmap (fmap (SOP . Z)) (noSelectorsParser modifiers shape)+      Infix{} ->+        err typeName "infix constructors"+  ADT _ typeName Nil ->+    err typeName "empty data types"+  ADT _ typeName (_ :* _ :* _) ->+    err typeName "sum types"+  Newtype _ _ (Record _ fields) ->+    fmap (fmap (SOP . Z)) (fieldsParser modifiers fields)+  Newtype _ typeName (Constructor _) ->+    err typeName "constructors without field labels"+  where+    err typeName message = Errors $ pure $+      "getopt-generics doesn't support " ++ message +++      " (" ++ typeName ++ ")."++fieldsParser :: All HasArguments xs =>+  Modifiers -> NP FieldInfo xs -> Result (Parser Unnormalized (NP I xs))+fieldsParser modifiers = \ case+  Nil -> return $ emptyParser Nil+  FieldInfo fieldName :* rest ->+    fmap (fmap (\ (a, r) -> a :* r)) $+      combine (fmap (fmap I) $ (argumentsParser modifiers (Just fieldName))) (fieldsParser modifiers rest)++noSelectorsParser :: All HasArguments xs =>+  Modifiers -> Shape xs -> Result (Parser Unnormalized (NP I xs))+noSelectorsParser modifiers = \ case+  ShapeNil -> return $ emptyParser Nil+  ShapeCons rest -> +    fmap (fmap (\ (a, r) -> a :* r)) $+      combine (fmap (fmap I) $ (argumentsParser modifiers Nothing)) (noSelectorsParser modifiers rest)

@@ -0,0 +1,32 @@++module WithCli.Normalize (+  normalize,+  matches,+ ) where++import           Data.Char++matches :: String -> String -> Bool+matches a b =+  normalize a == normalize b++normalize :: String -> String+normalize s =+  if all (not . isAllowedChar) s+    then s+    else+      slugify $+      dropWhile (== '-') $+      filter isAllowedChar $+      map (\ c -> if c == '_' then '-' else c) $+      s+  where+    slugify (a : r)+      | isUpper a = slugify (toLower a : r)+    slugify (a : b : r)+      | isUpper b = a : '-' : slugify (toLower b : r)+      | otherwise = a : slugify (b : r)+    slugify x = x++isAllowedChar :: Char -> Bool+isAllowedChar c = (isAscii c && isAlphaNum c) || (c `elem` "-_")

@@ -0,0 +1,135 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module WithCli.Parser where++import           Data.Orphans ()+import           Prelude ()+import           Prelude.Compat++import           Control.Arrow+import           Control.Monad+import           System.Console.GetOpt as Base++import           System.Console.GetOpt.Generics.Modifier.Types+import           WithCli.Flag+import           WithCli.Normalize+import           WithCli.Result++data NonOptionsParser uninitialized =+  NonOptionsParser {+    nonOptionsType :: String,+    nonOptionsParser :: [String] -> Result (uninitialized -> uninitialized, [String])+  }++combineNonOptionsParser :: [NonOptionsParser u] -> [NonOptionsParser v]+  -> [NonOptionsParser (u, v)]+combineNonOptionsParser a b =+  map (modMod first) a +++  map (modMod second) b+  where+    modMod :: ((a -> a) -> (b -> b)) -> NonOptionsParser a -> NonOptionsParser b+    modMod f (NonOptionsParser field parser) =+      NonOptionsParser field (fmap (fmap (first f)) parser)++data Parser phase a where+  Parser :: {+    parserDefault :: uninitialized,+    parserOptions :: [OptDescr (Result (uninitialized -> uninitialized))],+    parserNonOptions :: [NonOptionsParser uninitialized],+    parserConvert :: uninitialized -> Result a+  } -> Parser phase a++instance Functor (Parser phase) where+  fmap f (Parser def options nonOptions convert) =+    Parser def options nonOptions (fmap f . convert)++-- phases:+data Unnormalized+data Normalized++emptyParser :: a -> Parser phase a+emptyParser a = Parser {+  parserDefault = a,+  parserOptions = [],+  parserNonOptions = [],+  parserConvert = return+}++normalizeParser :: Parser Unnormalized a -> Parser Normalized a+normalizeParser (Parser d options nonOptions convert) =+  Parser d (map (mapLongOptions normalize) options) nonOptions convert+  where+    mapLongOptions :: (String -> String) -> OptDescr a -> OptDescr a+    mapLongOptions f (Option shorts longs argDescr help) =+      Option shorts (map f longs) argDescr help++modParserOptions :: (forall x . [OptDescr (Result x)] -> [OptDescr (Result x)])+  -> Parser Unnormalized a -> Parser Unnormalized a+modParserOptions f (Parser def options nonOptions convert) =+  Parser def (f options) nonOptions convert++combine :: forall a b phase .+  Result (Parser phase a) -> Result (Parser phase b)+  -> Result (Parser phase (a, b))+combine a b = inner <$> a <*> b+  where+    inner :: Parser phase a -> Parser phase b -> Parser phase (a, b)+    inner (Parser defaultA optionsA nonOptionsA convertA) (Parser defaultB optionsB nonOptionsB convertB) =+      Parser {+        parserDefault = (defaultA, defaultB),+        parserOptions =+          map (fmap (fmap first)) optionsA ++ map (fmap (fmap second)) optionsB,+        parserNonOptions = combineNonOptionsParser nonOptionsA nonOptionsB,+        parserConvert =+          \ (u, v) -> (,) <$> (convertA u) <*> (convertB v)+      }++fillInOptions :: [Result (u -> u)] -> u -> Result u+fillInOptions [] u = return u+fillInOptions (option : options) u = do+  f <- option+  fillInOptions options (f u)++fillInNonOptions :: [[String] -> Result (u -> u, [String])] -> [String] -> u+  -> Result u+fillInNonOptions (parser : parsers) nonOptions@(_ : _) u = do+  (p, rest) <- parser nonOptions+  fillInNonOptions parsers rest (p u)+fillInNonOptions [] [] u =+  return u+fillInNonOptions [] nonOptions _ =+  Errors (map ("unknown argument: " ++) nonOptions)+fillInNonOptions _ [] u = return u++runParser :: String -> Modifiers -> Parser Normalized a -> [String] -> Result a+runParser progName modifiers Parser{..} args = do+  let versionOptions = maybe []+        (\ v -> pure $ versionOption (progName ++ " version " ++ v))+        (getVersion modifiers)+      options = map (fmap NoHelp) parserOptions ++ [helpOption] ++ versionOptions+      (flags, nonOptions, errs) =+        Base.getOpt Base.Permute options args+  case foldFlags flags of+    Help -> OutputAndExit $+      let fields = case getPositionalArgumentType modifiers of+            Nothing -> map nonOptionsType parserNonOptions+            Just typ -> ["[" ++ typ ++ "]"]+      in usage progName fields (map void options)+    Version msg -> OutputAndExit msg+    NoHelp innerFlags ->+      reportErrors errs *>+      (fillInOptions innerFlags parserDefault >>=+       fillInNonOptions (map nonOptionsParser parserNonOptions) nonOptions >>=+       parserConvert)+  where+    reportErrors :: [String] -> Result ()+    reportErrors = \ case+      [] -> return ()+      errs -> Errors errs

@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ViewPatterns #-}++module WithCli.Result (+  Result(..),+  handleResult,+  sanitize,+ ) where++import           Prelude ()+import           Prelude.Compat++import           Control.Arrow+import           Data.List.Compat+import           System.Exit+import           System.IO++-- | Type to wrap results from the pure parsing functions.+data Result a+  = Success a+    -- ^ The CLI was used correctly and a value of type @a@ was+    --   successfully constructed.+  | Errors [String]+    -- ^ The CLI was used incorrectly. The 'Result' contains a list of error+    --   messages.+    --+    --   It can also happen that the data type you're trying to use isn't+    --   supported. See the+    --   <https://github.com/zalora/getopt-generics#getopt-generics README> for+    --   details.+  | OutputAndExit String+    -- ^ The CLI was used with @--help@. The 'Result' contains the help message.+  deriving (Show, Eq, Ord, Functor)++instance Applicative Result where+  pure = Success+  OutputAndExit message <*> _ = OutputAndExit message+  _ <*> OutputAndExit message = OutputAndExit message+  Success f <*> Success x = Success (f x)+  Errors a <*> Errors b = Errors (a ++ b)+  Errors errs <*> Success _ = Errors errs+  Success _ <*> Errors errs = Errors errs++instance Monad Result where+  return = pure+  Success a >>= b = b a+  Errors errs >>= _ = Errors errs+  OutputAndExit message >>= _ = OutputAndExit message++  (>>) = (*>)++handleResult :: Result a -> IO a+handleResult result = case result of+  Success a -> return a+  OutputAndExit message -> do+    putStr $ sanitize message+    exitWith ExitSuccess+  Errors errs -> do+    hPutStr stderr $ sanitize $ intercalate "\n" errs+    exitWith $ ExitFailure 1++sanitize :: String -> String+sanitize =+  lines >>>+  map stripTrailingSpaces >>>+  filter (not . null) >>>+  map (++ "\n") >>>+  concat++stripTrailingSpaces :: String -> String+stripTrailingSpaces =+  reverse . inner . dropWhile (`elem` [' ', '\n']) . reverse+  where+    inner s = case s of+      ('\n' : ' ' : r) -> inner ('\n' : r)+      (a : r) -> a : inner r+      [] -> []

@@ -1,44 +0,0 @@--module BashProtocol (testBashProtocol) where--import           Control.Exception-import           Control.Monad-import           Data.List-import           System.Environment.Compat-import           System.FilePath-import           System.IO-import           System.IO.Silently-import           System.Process-import           Test.Hspec--testBashProtocol :: FilePath -> String -> IO ()-testBashProtocol program bashProtocol = do-  assert (takeFileName program == "program") (return ())-  let protocol = parseProtocol bashProtocol-  testProtocol (takeDirectory program) protocol--data Protocol-  = Protocol {-    _command :: String,-    _expected :: [String]-  }-  deriving (Show)--parseProtocol :: String -> [Protocol]-parseProtocol = inner . lines-  where-    inner :: [String] -> [Protocol]-    inner [] = []-    inner (('$' : ' ' : command) : rest) =-      let (expected, next) = span (not . ("$ " `isPrefixOf`)) rest in-      Protocol command expected : inner next-    inner lines = error ("parseProtocol: cannot parse: " ++ show lines)--testProtocol :: FilePath -> [Protocol] -> IO ()-testProtocol programDir protocol = do-  path <- getEnv "PATH"-  setEnv "PATH" (programDir ++ ":" ++ path)-  forM_ protocol $ \ (Protocol command expected) -> do-    hPutStrLn stderr ("running: " ++ command)-    output <- hCapture_ [stdout, stderr] $ system command-    output `shouldBe` unlines expected

@@ -1,57 +0,0 @@--import           Prelude ()-import           Prelude.Compat--import           Control.Monad-import           Data.List-import           System.Directory-import           System.Exit.Compat-import           System.FilePath-import           System.IO.Temp-import           System.Process-import           Test.Hspec--import           BashProtocol--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  files <- runIO $-    map ("docs" </>) <$>-    filter ((".hs" ==) . takeExtension) <$>-    sort <$>-    getDirectoryContents "docs"--  forM_ files $ \ file -> do-    describe "docs directory ghc" $ do-      it ("compile and run " ++ file) $ do-        withSystemTempDirectory "getopt-generics-test" $ \ tempDir -> do-          compile tempDir file >>= execute file--compile :: FilePath -> FilePath -> IO FilePath-compile tempDir file = do-  let program = tempDir </> "program"-  callCommandCompat $ "cabal exec -- ghc " ++ file ++-    " -outputdir " ++ (tempDir </> "build") ++-    " -o " ++ program ++-    " -isrc -O0" ++-    " -Wall -Werror -fno-warn-unused-binds -fno-warn-name-shadowing"-  return program--execute :: FilePath -> FilePath -> IO ()-execute haskellFile program = do-  let bashProtocolFile = dropExtension haskellFile <.> "bash-protocol"-  exists <- doesFileExist bashProtocolFile-  if not exists-    then callCommandCompat $ program ++ " --help"-    else do-      testBashProtocol program =<< readFile bashProtocolFile--callCommandCompat :: String -> IO ()-callCommandCompat command = do-  exitCode <- system command-  case exitCode of-    ExitSuccess -> return ()-    failure@ExitFailure{} -> exitWith failure

@@ -0,0 +1,51 @@++module ExamplesSpec where++import           Prelude ()+import           Prelude.Compat++import           Control.Monad+import           System.FilePath+import           Test.Hspec++import           ShellProtocol++import qualified CustomOption+import qualified CustomOptionRecord+import qualified RecordType+import qualified Simple+import qualified SimpleRecord+import qualified Test01+import qualified Test02+import qualified Test03+import qualified Test04++examples :: [(IO (), String)]+examples =+  (Test01.main, "Test01") :+  (Test02.main, "Test02") :+  (Test03.main, "Test03") :+  (Test04.main, "Test04") :++  (Simple.main, "Simple") :+  (SimpleRecord.main, "SimpleRecord") :+  (RecordType.main, "RecordType") :+  (SimpleRecord.main, "SimpleRecord") :+  (CustomOption.main, "CustomOption") :+  (CustomOptionRecord.main, "CustomOptionRecord") :+  []++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "shell protocols" $ do+    forM_ examples $ \ (program, name) ->+      it name $ do+        test program name++test :: IO () -> String -> IO ()+test program name = do+  protocol <- readFile ("docs" </> name <.> "shell-protocol")+  testShellProtocol program protocol

@@ -13,7 +13,7 @@ spec = do   describe "AddShortOption" $ do     it "allows modifiers for short options" $ do-      modsParse [AddShortOption "camel-case" 'x'] "-x foo"+      modsParse [AddShortOption "camelCase" 'x'] "-x foo"         `shouldBe` Success (CamelCaseOptions "foo")      it "allows modifiers in camelCase" $ do@@ -39,19 +39,17 @@        it "disregards the earlier renaming" $ do         let Errors errs = parse' "--foo foo"-        errs `shouldContain` ["unrecognized option `--foo'"]+        errs `shouldContain` ["unrecognized option `--foo'\n"]      it "contains renamed options in error messages" $ do       let Errors errs = modsParse             [RenameOption "camelCase" "foo"]             "" :: Result CamelCaseOptions+      -- _ <- error $ show errs       show errs `shouldNotContain` "camelCase"+      show errs `shouldNotContain` "camel-case"       show errs `shouldContain` "foo" -    it "allows to address fields in Modifiers in slugified form" $ do-      modsParse [RenameOption "camel-case" "foo"] "--foo bar"-        `shouldBe` Success (CamelCaseOptions "bar")-     it "" $ do       modsParse [RenameOption "bar" "one", RenameOption "baz" "two"] "--one 1 --two foo"         `shouldBe` Success (Foo (Just 1) "foo" False)@@ -59,7 +57,7 @@   describe "AddVersionFlag" $ do     it "implements --version" $ do       let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version" :: Result Foo-      output `shouldBe` "prog-name version 1.0.0\n"+      output `shouldBe` "prog-name version 1.0.0"      it "--help takes precedence over --version" $ do       let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version --help" :: Result Foo

@@ -1,9 +1,11 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}  module ModifiersSpec.UseForPositionalArgumentsSpec where  import           Data.List import qualified GHC.Generics as GHC+import           System.Environment import           Test.Hspec  import           System.Console.GetOpt.Generics@@ -43,7 +45,7 @@       [UseForPositionalArguments "positionalArguments" "type"]       "--positional-arguments foo"         `shouldBe`-      (Errors ["unrecognized option `--positional-arguments'"]+      (Errors ["unrecognized option `--positional-arguments'\n"]         :: Result WithPositionalArguments)    it "complains about fields that don't have type [String]" $ do@@ -67,3 +69,14 @@           []     (modsParse modifiers [] :: Result WithMultiplePositionalArguments)       `shouldBe` Errors ["UseForPositionalArguments can only be used once"]++  context "when used without selector" $ do+    it "automatically uses positional arguments for [Int]" $ do+      withArgs (words "1 2 3") $+        withCli $ \ (xs :: [Int]) -> do+          xs `shouldBe` [1, 2, 3]++    it "automatically uses positional arguments for [String]" $ do+      withArgs (words "foo bar") $+        withCli $ \ (xs :: [String]) -> do+          xs `shouldBe` (words "foo bar")

@@ -0,0 +1,50 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module ShellProtocol (testShellProtocol) where++import           Control.Exception+import           Control.Monad+import           Data.List+import           System.Environment+import           System.Exit+import           System.IO+import           System.IO.Silently+import           Test.Hspec++testShellProtocol :: IO () -> String -> IO ()+testShellProtocol program shellProtocol = do+  let protocol = parseProtocol shellProtocol+  testProtocol program protocol++data Protocol+  = Protocol {+    _args :: [String],+    _expected :: [String]+  }+  deriving (Show)++parseProtocol :: String -> [Protocol]+parseProtocol = inner . lines+  where+    inner :: [String] -> [Protocol]+    inner [] = []+    inner ((words -> "$" : "program" : args) : rest) =+      let (expected, next) = span (not . ("$ " `isPrefixOf`)) rest in+      Protocol args expected : inner next+    inner lines = error ("parseProtocol: cannot parse: " ++ show lines)++testProtocol :: IO () -> [Protocol] -> IO ()+testProtocol program protocol = do+  forM_ protocol $ \ (Protocol args expected) -> do+    output <- hCapture_ [stdout, stderr] $+      handle (\ (e :: ExitCode) -> printExitCode e) $+      withArgs args $+      withProgName "program" $+      program+    output `shouldBe` unlines expected++printExitCode :: ExitCode -> IO ()+printExitCode e = case e of+  ExitFailure n -> hPutStrLn stderr ("# exit-code " ++ show n)+  ExitSuccess -> return ()

@@ -1,79 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--module System.Console.GetOpt.Generics.FieldStringSpec where--import           Data.Char-import           Test.Hspec-import           Test.QuickCheck hiding (Success)--import           System.Console.GetOpt.Generics.FieldString--normalize :: String -> String-normalize = normalized . mkFieldString--isValidInputChar :: Char -> Bool-isValidInputChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_"--isAllowedOutputChar :: Char -> Bool-isAllowedOutputChar c = c `elem` ['a' .. 'z'] ++ ['0' .. '9'] ++ "-"--upperCaseChar :: Gen Char-upperCaseChar = elements ['A' .. 'Z']--spec :: Spec-spec = do-  describe "normalized" $ do-    it "is idempotent" $ do-      property $ \ x -> do-        let once = normalize x-            twice = normalize once-        once `shouldBe` twice--    it "replaces underscores with dashes" $ do-      normalize "foo_bar" `shouldBe` "foo-bar"--    it "doesn't modify digits" $ do-      normalize "foo2bar" `shouldBe` "foo2bar"--    it "when there's one valid character it returns only dashes and lower case characters" $ do-      property $ \ x ->-        any isValidInputChar x ==>-        normalize x `shouldSatisfy`-          (\ s -> all isAllowedOutputChar s)--    it "when there are no valid characters it returns its input" $ do-      property $ forAll (listOf (arbitrary `suchThat` (not . isValidInputChar))) $ \ x ->-        normalize x `shouldBe` x--    it "replaces camelCase with dashes" $ do-      let isValidPrefixChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z']-      property $-        \ prefix suffix ->-        (any isValidPrefixChar prefix) ==>-        forAll upperCaseChar $ \ upper ->-        counterexample (prefix ++ [upper] ++ suffix) $-        normalize (prefix ++ [upper] ++ suffix)-          `shouldBe`-            normalize prefix ++ "-" ++ normalize (toLower upper : suffix)--  describe "matches" $ do-    it "matches normalized strings" $ do-      property $ \ s ->-        normalize s `matches` mkFieldString s--    it "matches unnormalized strings" $ do-      property $ \ s ->-        s `matches` mkFieldString s--  describe "renameUnnormalized" $ do-    it "allows to rename the unnormalized field names" $ do-      let f "camelCaseFoo" = Just "caseFoo"-          f _ = Nothing-      normalized (renameUnnormalized f (mkFieldString "camelCaseFoo")) `shouldBe`-        "case-foo"--    it "doesn't allow to rename normalized field names" $ do-      let f "camel-case-foo" = Just "case-foo"-          f _ = Nothing-      normalized (renameUnnormalized f (mkFieldString "camelCaseFoo")) `shouldBe`-        "camel-case-foo"

@@ -2,34 +2,15 @@  module System.Console.GetOpt.Generics.ModifierSpec where -import           Data.Char-import           Data.Proxy import qualified GHC.Generics import           Generics.SOP import           Test.Hspec-import           Test.QuickCheck hiding (Result(..)) -import           System.Console.GetOpt.Generics.GetArguments import           System.Console.GetOpt.Generics.Modifier-import           System.Console.GetOpt.Generics.Result+import           Util  spec :: Spec spec = do-  describe "deriveShortOptions" $ do-    it "includes modifiers for short options" $ do-      let [AddShortOption long short] = deriveShortOptions (Proxy :: Proxy Foo)-      (long, short) `shouldBe` ("bar", 'b')--    it "doesn't include modifiers for short options in case of overlaps" $ do-      null (deriveShortOptions (Proxy :: Proxy Overlap))--  describe "mkShortModifiers" $ do-    it "returns only lower-case ascii alpha characters as short options" $ do-      property $ \ strings ->-        all-          (\ (AddShortOption _ c) -> isLower c && isAscii c && isAlpha c)-          (mkShortModifiers strings)-   describe "insertWith" $ do     it "combines existing values with the given function" $ do       insertWith (++) (1 :: Integer) "bar" [(1, "foo")]@@ -37,16 +18,8 @@    describe "getVersion" $ do     it "returns the version" $ do-      let modifiers = mkModifiers [AddVersionFlag "1.0.0"]+      let modifiers = unsafeModifiers [AddVersionFlag "1.0.0"]       getVersion modifiers `shouldBe` Just "1.0.0"--  context "when used with Modifiers" $ do-    describe "parseArguments" $ do-      it "allows to specify a flag specific help" $ do-        let OutputAndExit output =-              parseArguments "prog-name" [AddOptionHelp "bar" "bar help text"]-                (words "--help") :: Result Foo-        output `shouldContain` "--bar=STRING  bar help text"  data Foo   = Foo {

@@ -1,66 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module System.Console.GetOpt.Generics.ResultSpec where--import           Control.Exception-import           Data.List-import           System.Exit-import           System.IO-import           System.IO.Silently-import           Test.Hspec-import           Test.QuickCheck hiding (Result(..))--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"]--  describe "errors" $ do-    it "removes trailing newlines" $ do-      (errors ["foo\n", "bar", "baz\n"] :: Result ()) `shouldBe`-        Errors ["foo", "bar", "baz"]--  describe "outputAndExit" $ do-    it "removes trailing spaces" $ do-      (outputAndExit "foo \nbar" :: Result ()) `shouldBe`-        OutputAndExit "foo\nbar"--    it "removes trailing spaces at the end" $ do-      (outputAndExit "foo " :: Result ()) `shouldBe`-        OutputAndExit "foo"--    it "quickcheck" $ do-      property $ \ s ->-        let OutputAndExit output = outputAndExit s-        in output `shouldSatisfy` (not . (" \n" `isInfixOf`))--    it "only strips spaces" $ do-      property $ \ s ->-        let OutputAndExit output = outputAndExit s-        in-          filter (/= ' ') output-            `shouldBe`-          filter (/= ' ') s--  describe "handleResult" $ do-    it "appends '\\n' at the end of error messages if missing" $ do-      output <- hCapture_ [stderr] $ do-        handle (\ (_ :: ExitCode) -> return ()) $ do-          _ <- handleResult (Errors ["foo", "bar\n", "baz"])-          return ()-      output `shouldBe` "foo\nbar\nbaz\n"--    context "OutputAndExit" $ do-      it "throws ExitSuccess" $ do-        handleResult (OutputAndExit "foo")-          `shouldThrow` (== ExitSuccess)--    context "Errors" $ do-      it "throws an ExitFailure" $ do-        handleResult (Errors ["foo"])-          `shouldThrow` (== ExitFailure 1)

@@ -1,64 +0,0 @@--module System.Console.GetOpt.Generics.SimpleSpec where--import           System.Environment-import           System.Exit-import           System.IO-import           System.IO.Silently-import           Test.Hspec--import           System.Console.GetOpt.Generics.Simple--spec :: Spec-spec = do-  describe "simpleCLI" $ do-    context "no arguments" $ do-      it "executes the operation in case of no command line arguments" $ do-        let main :: IO ()-            main = putStrLn "success"-        (capture_ $ withArgs [] $ simpleCLI main)-          `shouldReturn` "success\n"--      it "produces nice error messages" $ do-        let main :: IO ()-            main = putStrLn "success"-        output <- hCapture_ [stderr] (withArgs ["foo"] (simpleCLI main) `shouldThrow` (== ExitFailure 1))-        output `shouldBe` "unknown argument: foo\n"--    context "1 argument" $ do-      it "creates CLIs for unary IO operations" $ do-        let main :: String -> IO ()-            main s = putStrLn ("success: " ++ s)-        (capture_ $ withArgs ["foo"] $ simpleCLI main)-          `shouldReturn` "success: foo\n"--      it "parses Ints" $ do-        let main :: Int -> IO ()-            main n = putStrLn ("success: " ++ show n)-        (capture_ $ withArgs ["12"] $ simpleCLI main)-          `shouldReturn` "success: 12\n"--      it "error parsing" $ do-        let main :: Int -> IO ()-            main n = putStrLn ("error: " ++ show n)-        output <- hCapture_ [stderr] (withArgs (words "12 foo") (simpleCLI main) `shouldThrow` (== ExitFailure 1))-        output `shouldBe` "unknown argument: foo\n"--      it "offers --help" $ do-        let main :: Int -> IO ()-            main n = putStrLn ("error: " ++ show n)-        output <- capture_ (withArgs ["--help"] (simpleCLI main) `shouldThrow` (== ExitSuccess))-        output `shouldContain` "[OPTIONS] INTEGER"-        output `shouldContain` "-h  --help  show help and exit"--    it "works for IO operations with 2 arguments" $ do-      let main :: Int -> Bool -> IO ()-          main n b = putStrLn ("success: " ++ show (n, b)) -      (capture_ $ withArgs (words "42 yes") $ simpleCLI main)-        `shouldReturn` "success: (42,True)\n"--    it "works for IO operations with 3 arguments" $ do-      let main :: String -> Int -> Bool -> IO ()-          main s n b = putStrLn ("success: " ++ show (s, n, b))-      (capture_ $ withArgs (words "foo 42 yes") $ simpleCLI main)-        `shouldReturn` "success: (\"foo\",42,True)\n"

@@ -8,16 +8,19 @@ import           Prelude () import           Prelude.Compat +import           Control.Exception import           Data.Foldable (forM_) import           Data.List (isPrefixOf, isSuffixOf)-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.QuickCheck hiding (Result(..))  import           System.Console.GetOpt.Generics import           Util+import           WithCli.Result  spec :: Spec spec = do@@ -26,7 +29,6 @@   part3   part4   part5-  part6  data Foo   = Foo {@@ -63,11 +65,15 @@       parse "--bool --baz foo" `shouldBe`         Success (Foo Nothing "foo" True) +    it "allows to overwrite String options" $ do+      parse "--baz one --baz two"+        `shouldBe` Success (Foo Nothing "two" False)+     context "with invalid arguments" $ do       it "prints out an error" $ do         let Errors messages = parse "--no-such-option" :: Result Foo         messages `shouldBe`-          ["unrecognized option `--no-such-option'",+          ["unrecognized option `--no-such-option'\n",            "missing option: --baz=STRING"]        it "prints errors for missing options" $ do@@ -101,8 +107,11 @@         output `shouldContain` "show help and exit"        it "does not contain trailing spaces" $ do-        let OutputAndExit output = parse "--help" :: Result Foo-        forM_ (lines output) $ \ line ->+        output <-+          hCapture_ [stdout] $+          handle (\ ExitSuccess -> return ()) $+          handleResult $ ((parse "--help" :: Result Foo) >> return ())+        forM_ (lines output) $ \ line -> do           line `shouldSatisfy` (not . (" " `isSuffixOf`))        it "complains when the options datatype is not allowed" $ do@@ -113,11 +122,6 @@         let OutputAndExit output = parse "--help" :: Result Foo         output `shouldSatisfy` ("prog-name [OPTIONS]\n" `isPrefixOf`) -  describe "parseArguments" $ do-    it "allows to overwrite String options" $ do-      parse "--baz one --baz two"-        `shouldBe` Success (Foo Nothing "two" False)- data ListOptions   = ListOptions {     multiple :: [Int]@@ -182,39 +186,6 @@       parse "--with-underscore foo"         `shouldBe` Success (WithUnderscore "foo") -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--part5 :: Spec-part5 = do-  describe "parseArguments" $ do-    context "CustomFields" $ do-      it "allows easy implementation of custom field types" $ do-        parse "--custom foo --custom-list bar --custom-maybe baz"-          `shouldBe` Success (CustomFields CFoo [CBar] (Just CBaz))- data WithoutSelectors   = WithoutSelectors String Bool Int   deriving (Eq, Show, GHC.Generic)@@ -222,8 +193,8 @@ instance Generic WithoutSelectors instance HasDatatypeInfo WithoutSelectors -part6 :: Spec-part6 = do+part5 :: Spec+part5 = do   describe "parseArguments" $ do     context "WithoutSelectors" $ do       it "populates fields without selectors from positional arguments" $ do@@ -248,43 +219,3 @@       it "allows to use tuples" $ do         (parse "42 bar" :: Result (Int, String))           `shouldBe` Success (42, "bar")--  describe "Option.Bool" $ do-    describe "parseArgument" $ do-      forM_ ["true", "True", "tRue", "TRUE", "yes", "yEs", "on", "oN"] $ \ true ->-        it ("parses '" ++ true ++ "' as True") $ do-          parseArgument true `shouldBe` Just True--      forM_ ["false", "False", "falSE", "FALSE", "no", "nO", "off", "ofF"] $ \ false ->-        it ("parses '" ++ false ++ "' as False") $ do-          parseArgument false `shouldBe` Just False--      it "parses every positive integer as true" $ do-        property $ \ (n :: Int) ->-          n > 0 ==>-          parseArgument (show n) `shouldBe` Just True--      it "parses every non-positive integer as false" $ do-        property $ \ (n :: Int) ->-          n <= 0 ==>-          parseArgument (show n) `shouldBe` Just False--      it "doesn't parse 'foo'" $ do-        parseArgument "foo" `shouldBe` (Nothing :: Maybe Bool)--  describe "Option.Double" $ do-    it "parses doubles" $ do-      parseArgument "1.2" `shouldBe` Just (1.2 :: Double)--    it "renders as NUMBER in help and error output" $ do-      argumentType (Proxy :: Proxy Double) `shouldBe` "NUMBER"--    it "parses doubles that start with a dot" $ do-      parseArgument ".4" `shouldBe` Just (0.4 :: Double)--  describe "Option.Float" $ do-    it "parses floats" $ do-      parseArgument "1.2" `shouldBe` Just (1.2 :: Float)--    it "renders as NUMBER in help and error output" $ do-      argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER"

@@ -3,11 +3,18 @@ module Util where  import           System.Console.GetOpt.Generics+import           System.Console.GetOpt.Generics.Modifier -parse :: (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+parse :: (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) =>   String -> Result a parse = modsParse [] -modsParse :: (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+modsParse :: (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) =>   [Modifier] -> String -> Result a modsParse modifiers = parseArguments "prog-name" modifiers . words++unsafeModifiers :: [Modifier] -> Modifiers+unsafeModifiers mods = case mkModifiers mods of+  Success x -> x+  Errors errs -> error ("unsafeModifiers: " ++ show errs)+  OutputAndExit msg -> error ("unsafeModifiers: " ++ show msg)

@@ -0,0 +1,26 @@++module WithCli.ArgumentSpec where++import           Data.Proxy+import           Test.Hspec++import           WithCli.Argument++spec :: Spec+spec = do+  describe "Option.Double" $ do+    it "parses doubles" $ do+      parseArgument "1.2" `shouldBe` Just (1.2 :: Double)++    it "renders as NUMBER in help and error output" $ do+      argumentType (Proxy :: Proxy Double) `shouldBe` "NUMBER"++    it "parses doubles that start with a dot" $ do+      parseArgument ".4" `shouldBe` Just (0.4 :: Double)++  describe "Option.Float" $ do+    it "parses floats" $ do+      parseArgument "1.2" `shouldBe` Just (1.2 :: Float)++    it "renders as NUMBER in help and error output" $ do+      argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER"

@@ -0,0 +1,34 @@+{-# LANGUAGE ScopedTypeVariables #-}++module WithCli.HasArgumentsSpec where++import           Control.Monad+import           Test.Hspec+import           Test.QuickCheck++import           WithCli.HasArguments++spec :: Spec+spec = do+  describe "parseBool" $ do+    forM_ ["true", "True", "tRue", "TRUE", "yes", "yEs", "on", "oN"] $ \ true ->+      it ("parses '" ++ true ++ "' as True") $ do+        parseBool true `shouldBe` Just True++    forM_ ["false", "False", "falSE", "FALSE", "no", "nO", "off", "ofF"] $ \ false ->+      it ("parses '" ++ false ++ "' as False") $ do+        parseBool false `shouldBe` Just False++    it "parses every positive integer as true" $ do+      property $ \ (n :: Int) ->+        n > 0 ==>+        parseBool (show n) `shouldBe` Just True++    it "parses every non-positive integer as false" $ do+      property $ \ (n :: Int) ->+        n <= 0 ==>+        parseBool (show n) `shouldBe` Just False++    it "doesn't parse 'foo'" $ do+      parseBool "foo" `shouldBe` (Nothing :: Maybe Bool)+

@@ -0,0 +1,63 @@+{-# LANGUAGE ViewPatterns #-}++module WithCli.NormalizeSpec where++import           Data.Char+import           Test.Hspec+import           Test.QuickCheck hiding (Success)++import           WithCli.Normalize++isValidInputChar :: Char -> Bool+isValidInputChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_"++isAllowedOutputChar :: Char -> Bool+isAllowedOutputChar c = c `elem` ['a' .. 'z'] ++ ['0' .. '9'] ++ "-"++upperCaseChar :: Gen Char+upperCaseChar = elements ['A' .. 'Z']++spec :: Spec+spec = do+  describe "normalize" $ do+    it "is idempotent" $ do+      property $ \ x -> do+        let once = normalize x+            twice = normalize once+        once `shouldBe` twice++    it "replaces underscores with dashes" $ do+      normalize "foo_bar" `shouldBe` "foo-bar"++    it "doesn't modify digits" $ do+      normalize "foo2bar" `shouldBe` "foo2bar"++    it "when there's one valid character it returns only dashes and lower case characters" $ do+      property $ \ x ->+        any isValidInputChar x ==>+        normalize x `shouldSatisfy`+          (\ s -> all isAllowedOutputChar s)++    it "when there are no valid characters it returns its input" $ do+      property $ forAll (listOf (arbitrary `suchThat` (not . isValidInputChar))) $ \ x ->+        normalize x `shouldBe` x++    it "replaces camelCase with dashes" $ do+      let isValidPrefixChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z']+      property $+        \ prefix suffix ->+        (any isValidPrefixChar prefix) ==>+        forAll upperCaseChar $ \ upper ->+        counterexample (prefix ++ [upper] ++ suffix) $+        normalize (prefix ++ [upper] ++ suffix)+          `shouldBe`+            normalize prefix ++ "-" ++ normalize (toLower upper : suffix)++  describe "matches" $ do+    it "matches normalized strings" $ do+      property $ \ s ->+        normalize s `matches` s++    it "matches unnormalized strings" $ do+      property $ \ s ->+        s `matches` s

@@ -0,0 +1,29 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++module WithCli.ParserSpec where++import           Prelude ()+import           Prelude.Compat++import           Test.Hspec++import           WithCli.Parser+import           WithCli.Result+import           Util++spec :: Spec+spec = do+  describe "runParser" $ do+    it "foo" $ do+      let fa :: Parser phase Int+          fa = Parser {+            parserDefault = Nothing,+            parserOptions = [],+            parserNonOptions =+              (NonOptionsParser "type" (\ (s : r) -> (, r) <$> Success (const $ Just $ read s))) :+              [],+            parserConvert = \ (Just x) -> return x+          }+      let i = runParser "program" (unsafeModifiers []) fa ["42"]+      i `shouldBe` Success 42

@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module WithCli.ResultSpec where++import           Data.Char+import           Data.List+import           Safe+import           System.Exit+import           Test.Hspec+import           Test.QuickCheck hiding (Result(..))++import           WithCli.Result++spec :: Spec+spec = do+  describe "Result" $ do+    context ">>" $ do+      it "collects errors" $ do+        (Errors ["foo"] >> Errors ["bar"] :: Result ())+          `shouldBe` Errors ["foo", "bar"]++  describe "handleResult" $ do+    context "OutputAndExit" $ do+      it "throws ExitSuccess" $ do+        handleResult (OutputAndExit "foo")+          `shouldThrow` (== ExitSuccess)++    context "Errors" $ do+      it "throws an ExitFailure" $ do+        handleResult (Errors ["foo"])+          `shouldThrow` (== ExitFailure 1)++  describe "sanitize" $ do+    it "removes empty lines" $ do+      property $ \ (unlines -> s) -> do+        sanitize s `shouldNotContain` "\n\n"++    it "adds a newline at the end if missing" $ do+      property $ \ (unlines -> s) ->+        not (null (sanitize s)) ==>+        lastMay (sanitize s) `shouldBe` Just '\n'++    it "only strips spaces" $ do+      property $ \ (unlines -> s) -> do+        counterexample s $ do+          let expected = case s of+                "" -> ""+                x | lastMay x == Just '\n' -> x+                x -> x ++ "\n"+          filter (not . isSpace) (sanitize s) `shouldBe` filter (not . isSpace) expected++    it "removes trailing spaces" $ do+      property $ \ (unlines -> s) -> do+        sanitize s `shouldSatisfy` (not . (" \n" `isInfixOf`))

@@ -0,0 +1,45 @@++module WithCliSpec where++import           System.Environment+import           System.Exit+import           System.IO+import           System.IO.Silently+import           Test.Hspec++import           WithCli++spec :: Spec+spec = do+  describe "withCli" $ do+    context "no arguments" $ do+      it "executes the operation in case of no command line arguments" $ do+        let main :: IO ()+            main = putStrLn "success"+        (capture_ $ withArgs [] $ withCli main)+          `shouldReturn` "success\n"++      it "produces nice error messages" $ do+        let main :: IO ()+            main = putStrLn "success"+        output <- hCapture_ [stderr] (withArgs ["foo"] (withCli main) `shouldThrow` (== ExitFailure 1))+        output `shouldBe` "unknown argument: foo\n"++    context "1 argument" $ do+      it "parses Ints" $ do+        let main :: Int -> IO ()+            main n = putStrLn ("success: " ++ show n)+        (capture_ $ withArgs ["12"] $ withCli main)+          `shouldReturn` "success: 12\n"++      it "error parsing" $ do+        let main :: Int -> IO ()+            main n = putStrLn ("error: " ++ show n)+        output <- hCapture_ [stderr] (withArgs (words "12 foo") (withCli main) `shouldThrow` (== ExitFailure 1))+        output `shouldBe` "unknown argument: foo\n"++      it "handle Maybes as positional arguments with a proper error message" $ do+        let main :: Maybe Int -> IO ()+            main = error "main"+        output <- hCapture_ [stderr] (withCli main `shouldThrow` (== ExitFailure 1))+        output `shouldBe` "cannot use Maybes for positional arguments\n"