getopt-generics 0.8 → 0.9

raw patch · 7 files changed

+586/−424 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• getopt-generics.cabal +6/−1
• src/System/Console/GetOpt/Generics.hs +10/−417
• src/System/Console/GetOpt/Generics/GetArguments.hs +423/−0
• src/System/Console/GetOpt/Generics/Simple.hs +75/−0
• test/System/Console/GetOpt/Generics/ModifierSpec.hs +3/−1
• test/System/Console/GetOpt/Generics/SimpleSpec.hs +64/−0
• test/System/Console/GetOpt/GenericsSpec.hs +5/−5

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           getopt-generics-version:        0.8+version:        0.9 synopsis:       Simple command line argument parsing description:    "getopt-generics" tries to make it very simple to create command line argument parsers. An introductory example can be found in the <https://github.com/zalora/getopt-generics#getopt-generics README>. category:       Console, System@@ -38,8 +38,10 @@       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 spec@@ -64,8 +66,10 @@   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       ExamplesSpec       ModifiersSpec       ModifiersSpec.RenameOptionsSpec@@ -73,6 +77,7 @@       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       Example

@@ -1,30 +1,7 @@-{-# 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. An introductory example can be found in the--- <https://github.com/zalora/getopt-generics#getopt-generics README>.- module System.Console.GetOpt.Generics (   -- * IO API+  simpleCLI,   getArguments,   modifiedGetArguments,   -- * Pure API@@ -34,407 +11,23 @@   Modifier(..),   deriveShortOptions,   -- * Available Field Types+  -- fixme: hide methods?   Option(..),+  -- * SimpleCLI class+  SimpleCLI,+  ArgumentTypes,   -- * Re-exports from "Generics.SOP"   Generic,   HasDatatypeInfo,-  All2,   Code,-  Proxy(..)+  All2,+  SingI,+  Proxy(..),  ) 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.GetArguments 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.------   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@.-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 'getArguments'.------   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--    let (withPositionalArguments, additionalArgumentsErrors) =-          fillInPositionalArguments arguments $-            project options initialFieldStates-    either errors return additionalArgumentsErrors--    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 -> (NP FieldState xs, Either [String] ())-fillInPositionalArguments = inner . Just-  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). For---   an example see the---   <https://github.com/zalora/getopt-generics#getopt-generics README>.-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 == "true" = Just True-    | map toLower s == "false" = 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+import           System.Console.GetOpt.Generics.Simple

@@ -0,0 +1,423 @@+{-# 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. An introductory example can be found in the+-- <https://github.com/zalora/getopt-generics#getopt-generics README>.++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.+--+--   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@.+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 'getArguments'.+--+--   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). For+--   an example see the+--   <https://github.com/zalora/getopt-generics#getopt-generics README>.+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

@@ -0,0 +1,75 @@+{-# 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 nice CLI. @main@ can have+--   arbitrarily many parameters provided all parameters have an instance for 'Option'.+--+--   Example:+--+--   Given a file @myProgram.hs@:+--+--   > main :: IO ()+--   > main = simpleCLI myMain+--   >+--   > myMain :: String -> Int -> Bool -> IO ()+--   > myMain s i b = print (s, i, b)+--+--   you get:+--+--   > $ runhaskell myProgram.hs foo 42 true+--   > ("foo",42,True)+--   > $ runhaskell myProgram.hs foo 42 bar+--   > cannot parse as BOOL: bar+--   > $ runhaskell myProgram.hs --help+--   > myProgram.hs [OPTIONS] STRING INTEGER BOOL+--   >   -h  --help  show help and exit+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"

@@ -5,11 +5,13 @@ 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+import           System.Console.GetOpt.Generics.GetArguments import           System.Console.GetOpt.Generics.Modifier+import           System.Console.GetOpt.Generics.Result  spec :: Spec spec = do

@@ -0,0 +1,64 @@++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"

@@ -251,13 +251,13 @@    describe "Option.Bool" $ do     describe "parseArgument" $ do-      it "parses 'true' case-insensitively" $ do-        forM_ ["true", "True", "tRue", "TRUE"] $ \ true ->+      forM_ ["true", "True", "tRue", "TRUE", "yes", "yEs", "on", "oN"] $ \ true ->+        it ("parses '" ++ true ++ "' as True") $ do           parseArgument true `shouldBe` Just True -      it "parses 'false' case-insensitively" $ do-        forM_ ["false", "False", "falSE", "FALSE"] $ \ true ->-          parseArgument true `shouldBe` Just False+      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) ->