getopt-generics 0.1.1 → 0.2

raw patch · 4 files changed

+322/−95 lines, 4 filesdep +base-compatdep +hspec-expectationsdep +taggeddep −getopt-genericsdep −safePVP ok

version bump matches the API change (PVP)

Dependencies added: base-compat, hspec-expectations, tagged

Dependencies removed: getopt-generics, safe

API changes (from Hackage documentation)

Files

• getopt-generics.cabal +29/−30
• src/System/Console/GetOpt/Generics.hs +173/−65
• src/System/Console/GetOpt/Generics/Internal.hs +31/−0
• src/System/Console/GetOpt/Generics/Modifier.hs +89/−0

@@ -1,49 +1,48 @@+-- This file has been generated from package.yaml by Cabalize. name: getopt-generics-version: 0.1.1-category: Console, System+version: 0.2 synopsis: Simple command line argument parsing description:-  "getopt-generics" tries to make it very simple to create command line argument-  parsers. Documentation can be found in the-  <https://github.com/zalora/getopt-generics#getopt-generics README>.-license: BSD3-license-file: LICENSE+  "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 author: Linh Nguyen, Sönke Hahn-copyright: Zalora South East Asia Pte Ltd maintainer: linh.nguyen@zalora.com, soenke.hahn@zalora.com--cabal-version: >= 1.8+copyright: Zalora South East Asia Pte Ltd+license: BSD3+license-file: LICENSE build-type: Simple+cabal-version: >= 1.10 +source-repository head+  type: git+  location: https://github.com/zalora/getopt-generics+ library-  hs-source-dirs:-    src-  ghc-options:-    -Wall -fno-warn-name-shadowing+  hs-source-dirs: src   exposed-modules:-    System.Console.GetOpt.Generics+      System.Console.GetOpt.Generics+  other-modules:+      System.Console.GetOpt.Generics.Internal+      System.Console.GetOpt.Generics.Modifier   build-depends:       base == 4.*+    , base-compat >= 0.7     , generics-sop-    , safe+    , tagged+  ghc-options: -Wall -fno-warn-name-shadowing+  default-language: Haskell2010  test-suite spec-  type:-    exitcode-stdio-1.0-  hs-source-dirs:-    test, examples-  ghc-options:-    -Wall -threaded -fno-warn-name-shadowing -O0 -pgmL markdown-unlit-  main-is:-    Spec.hs+  type: exitcode-stdio-1.0+  hs-source-dirs: src, test, examples+  main-is: Spec.hs   build-depends:       base == 4.*-    , getopt-generics+    , base-compat >= 0.7     , generics-sop-     , hspec+    , hspec-expectations     , silently--source-repository head-  type:     git-  location: git://github.com/zalora/getopt-generics+    , tagged+  ghc-options: -Wall -fno-warn-name-shadowing -threaded -O0 -pgmL markdown-unlit+  default-language: Haskell2010

@@ -4,48 +4,97 @@ {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeSynonymInstances  #-} --- | "getopt-generics" tries to make it very simple to create command line--- argument parsers. Documentation can be found in the+{-# 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 (-  withArguments,+  -- * IO API+  getArguments,+  -- * Pure API+  parseArguments,+  Result(..),+  -- * Customizing the CLI+  Modifier(..),+  deriveShortOptions,+  -- * Available Field Types   Option(..),  ) where -import           Control.Applicative+import           Prelude ()+import           Prelude.Compat++import           Data.Char import           Data.List-import           Data.Monoid (Monoid, mempty) import           Generics.SOP-import           Safe-import           System.Console.GetOpt+import           System.Console.GetOpt.Compat import           System.Environment import           System.Exit import           System.IO+import           Text.Read.Compat -withArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>-  (a -> IO ()) -> IO ()-withArguments action = do+import           System.Console.GetOpt.Generics.Modifier+import           System.Console.GetOpt.Generics.Internal++-- | 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 = do   args <- getArgs-  case parseArgs args of-    Right (Right a) -> action a-    Left noAction -> noAction-    Right (Left errs) -> do+  progName <- getProgName+  case parseArguments progName [] args of+    Success a -> return a+    OutputAndExit message -> do+      putStrLn message+      exitWith ExitSuccess+    Errors errs -> do       mapM_ (hPutStrLn stderr) errs       exitWith $ ExitFailure 1 -parseArgs :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>-  [String] -> Either (IO ()) (Either [String] a)-parseArgs args = case datatypeInfo (Proxy :: Proxy a) of+-- | 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)++-- | Pure variant of 'getArguments'. Also allows to declare 'Modifier's.+--+--   Does not throw any exceptions.+parseArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+  String -> [Modifier] -> [String] -> Result a+parseArguments header modifiers args = case normalizedDatatypeInfo (Proxy :: Proxy a) of     ADT typeName _ (constructorInfo :* Nil) ->       case constructorInfo of-        (Record _ fields) -> processFields args fields+        (Record _ fields) -> processFields header modifiers args fields         Constructor{} ->           err typeName "constructors without field labels"         Infix{} ->@@ -55,19 +104,19 @@     ADT typeName _ (_ :* _ :* _) ->       err typeName "sum-types"     Newtype _ _ (Record _ fields) ->-      processFields args fields+      processFields header modifiers args fields     Newtype typeName _ (Constructor _) ->       err typeName "constructors without field labels"   where     err typeName message =-      Right $ Left ["getopt-generics doesn't support " ++ message ++ " (" ++ typeName ++ ")."]+      Errors ["getopt-generics doesn't support " ++ message ++ " (" ++ typeName ++ ")."]  processFields :: forall a xs . (Generic a, Code a ~ '[xs], SingI xs, All Option xs) =>-  [String] -> NP FieldInfo xs -> Either (IO ()) (Either [String] a)-processFields args fields =-  helpWrapper args fields $+  String -> [Modifier] -> [String] -> NP FieldInfo xs -> Result a+processFields header modifiers args fields =+  helpWrapper header modifiers args fields $   fmap (to . SOP . Z) $-  case getOpt Permute (mkOptDescrs fields) args of+  case getOpt Permute (mkOptDescrs modifiers fields) args of     (options, arguments, parseErrors) ->       let result :: Either [String] (NP I xs) =             collectErrors $ project options (mkEmptyArguments fields)@@ -86,14 +135,19 @@     ignoreRight = either id (const mempty)  mkOptDescrs :: forall xs . All Option xs =>-  NP FieldInfo xs -> [OptDescr (NS FieldState xs)]-mkOptDescrs fields =-  map toOptDescr $ sumList $ npMap mkOptDescr fields+  [Modifier] -> NP FieldInfo xs -> [OptDescr (NS FieldState xs)]+mkOptDescrs modifiers fields =+  map toOptDescr $ sumList $ npMap (mkOptDescr modifiers) fields  newtype OptDescrE a = OptDescrE (OptDescr (FieldState a)) -mkOptDescr :: forall a . Option a => FieldInfo a -> OptDescrE a-mkOptDescr (FieldInfo name) = OptDescrE $ Option [] [name] toOption ""+mkOptDescr :: forall a . Option a => [Modifier] -> FieldInfo a -> OptDescrE a+mkOptDescr modifiers (FieldInfo name) = OptDescrE $+  Option+    (mkShortOptions modifiers name)+    (mkLongOptions modifiers name)+    _toOption+    ""  toOptDescr :: NS OptDescrE xs -> OptDescr (NS FieldState xs) toOptDescr (Z (OptDescrE a)) = fmap Z a@@ -104,35 +158,49 @@ mkEmptyArguments fields = case (sing :: Sing xs, fields) of   (SNil, Nil) -> Nil   (SCons, FieldInfo name :* r) ->-    emptyOption name :* mkEmptyArguments r+    _emptyOption name :* mkEmptyArguments r   _ -> uninhabited "mkEmpty"   -- * showing help? +data HelpFlag = HelpFlag+ helpWrapper :: (All Option xs) =>-  [String] -> NP FieldInfo xs -> a -> Either (IO ()) a-helpWrapper args fields a =+  String -> [Modifier] -> [String] -> NP FieldInfo xs -> Either [String] a -> Result a+helpWrapper header modifiers args fields result =     case getOpt Permute [helpOption] args of-      ([], _, _) -> Right a-      (() : _, _, _) -> Left $ do-        progName <- getProgName-        let header = progName-        putStrLn (usageInfo header (mkOptDescrs fields))+      ([], _, _) -> case result of+        -- no help flag given+        Left errs -> Errors errs+        Right a -> Success a+      (HelpFlag : _, _, _) -> OutputAndExit $+        stripTrailingSpaces $+        usageInfo header $+          toOptDescrUnit (mkOptDescrs modifiers fields) +++          toOptDescrUnit [helpOption]   where-    helpOption = Option ['h'] ["help"] (NoArg ()) "show help and exit"+    helpOption :: OptDescr HelpFlag+    helpOption = Option ['h'] ["help"] (NoArg HelpFlag) "show help and exit" +    toOptDescrUnit :: [OptDescr a] -> [OptDescr ()]+    toOptDescrUnit = map (fmap (const ())) +stripTrailingSpaces :: String -> String+stripTrailingSpaces = unlines . map stripLines . lines+  where+    stripLines = reverse . dropWhile isSpace . reverse+ -- * helper functions for NS and NP  collectErrors :: NP FieldState xs -> Either [String] (NP I xs) collectErrors np = case np of   Nil -> Right Nil   (a :* r) -> case (a, collectErrors r) of-    (Success a, Right r) -> Right (I a :* r)+    (FieldSuccess a, Right r) -> Right (I a :* r)     (ParseErrors errs, r) -> Left (errs ++ either id (const []) r)     (Unset err, r) -> Left (err : either id (const []) r)-    (Success _, Left errs) -> Left errs+    (FieldSuccess _, Left errs) -> Left errs  npMap :: (All Option xs) => (forall a . Option a => f a -> g a) -> NP f xs -> NP g xs npMap _ Nil = Nil@@ -164,49 +232,89 @@ data FieldState a   = Unset String   | ParseErrors [String]-  | Success a+  | FieldSuccess a   deriving (Functor) +-- | Type class for all allowed field types.+--+--   Implementing custom instances to allow different types is possible. In the+--   easiest case you just implement 'argumentType' and 'parseArgument' (the+--   minimal complete definition).+--+--   (Unfortunately implementing instances for lists or 'Maybe's of custom types+--   is not very straightforward.) class Option a where-  toOption :: ArgDescr (FieldState a)-  emptyOption :: String -> FieldState a-  accumulate :: a -> a -> a-  accumulate _ x = x+  {-# 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 :: String -> FieldState a+  _emptyOption flagName = Unset+    ("missing option: --" ++ flagName ++ "=" ++ argumentType (Proxy :: Proxy a))++  -- | This is meant to be an internal function.+  _accumulate :: a -> a -> a+  _accumulate _ x = x++parseAsFieldState :: forall a . Option a => String -> FieldState a+parseAsFieldState s = case parseArgument s of+  Just a -> FieldSuccess a+  Nothing -> ParseErrors $ pure $+    "cannot parse as " ++ argumentType (Proxy :: Proxy a) ++ ": " ++ s+ combine :: Option a => FieldState a -> FieldState a -> FieldState a combine _ (Unset _) = impossible "combine" combine (ParseErrors e) (ParseErrors f) = ParseErrors (e ++ f) combine (ParseErrors e) _ = ParseErrors e combine (Unset _) x = x-combine (Success _) (ParseErrors e) = ParseErrors e-combine (Success a) (Success b) = Success (accumulate a b)+combine (FieldSuccess _) (ParseErrors e) = ParseErrors e+combine (FieldSuccess a) (FieldSuccess b) = FieldSuccess (_accumulate a b)  instance Option Bool where-  toOption = NoArg (Success True)-  emptyOption _ = Success False+  argumentType _ = "bool"+  parseArgument = impossible "Option.Bool.parseArguments" +  _toOption = NoArg (FieldSuccess True)+  _emptyOption _ = FieldSuccess False+ instance Option String where-  toOption = ReqArg Success "string"-  emptyOption flagName = Unset-    ("missing option: --" ++ flagName ++ "=string")+  argumentType _ = "string"+  parseArgument = Just  instance Option (Maybe String) where-  toOption = ReqArg (Success . Just) "string (optional)"-  emptyOption _ = Success Nothing+  argumentType _ = "string (optional)"+  parseArgument = Just . Just+  _emptyOption _ = FieldSuccess Nothing  instance Option [String] where-  toOption = ReqArg (Success . pure) "strings (multiple possible)"-  emptyOption _ = Success []-  accumulate = (++)--parseInt :: String -> FieldState Int-parseInt s = maybe (ParseErrors ["not an integer: " ++ s]) Success $ readMay s+  argumentType _ = "string (multiple possible)"+  parseArgument = Just . pure+  _emptyOption _ = FieldSuccess []+  _accumulate = (++)  instance Option Int where-  toOption = ReqArg parseInt "integer"-  emptyOption flagName = Unset-    ("missing option: --" ++ flagName ++ "=int")+  argumentType _ = "integer"+  parseArgument = readMaybe  instance Option (Maybe Int) where-  toOption = ReqArg (fmap Just . parseInt) "integer (optional)"-  emptyOption _ = Success Nothing+  argumentType _ = "integer (optional)"+  parseArgument s = case readMaybe s of+    Just i -> Just (Just i)+    Nothing -> Nothing+  _emptyOption _ = FieldSuccess Nothing++instance Option [Int] where+  argumentType _ = "integer (multiple possible)"+  parseArgument s = case readMaybe s of+    Just a -> Just [a]+    Nothing -> Nothing+  _emptyOption _ = FieldSuccess []+  _accumulate = (++)

@@ -0,0 +1,31 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE TypeFamilies        #-}++module System.Console.GetOpt.Generics.Internal where++import           Data.Char+import           Generics.SOP++normalizedDatatypeInfo :: (HasDatatypeInfo a, Code a ~ xss, SingI xss) =>+  Proxy a -> DatatypeInfo xss+normalizedDatatypeInfo p = mapFieldInfo (\ (FieldInfo s) -> FieldInfo (slugify s)) (datatypeInfo p)++mapFieldInfo :: (SingI xss) =>+  (forall b . FieldInfo b -> FieldInfo b) -> DatatypeInfo xss -> DatatypeInfo xss+mapFieldInfo f info = case info of+    (ADT mod name constructors) -> ADT mod name (hliftA (mapSingleCons f) constructors)+    (Newtype mod name constructor) -> Newtype mod name (mapSingleCons f constructor)+  where+    mapSingleCons :: (forall b . FieldInfo b -> FieldInfo b) -> ConstructorInfo xs -> ConstructorInfo xs+    mapSingleCons f c = case c of+      (Record name fields) -> Record name (hliftA f fields)+      cons@Infix{} -> cons+      cons@Constructor{} -> cons++slugify :: String -> String+slugify [] = []+slugify (x : xs)+  | isUpper x = '-' : toLower x : slugify xs+  | otherwise = x : slugify xs

@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs            #-}++module System.Console.GetOpt.Generics.Modifier (+  Modifier(..),+  deriveShortOptions,+  mkShortOptions,+  mkLongOptions,+ ) where++import           Data.List+import           Data.Maybe+import           Generics.SOP++import           System.Console.GetOpt.Generics.Internal++-- | 'Modifier's can be used to customize the command line parser.+data Modifier+  = AddShortOption String Char+    -- ^ @AddShortOption fieldName c@ adds the 'Char' @c@ as a short option for+    --   the field addressed by @fieldName@.+  | RenameOption String String+    -- ^ @RenameOption fieldName customName@ renames the option generated+    --   through the @fieldName@ by @customName@.+  deriving (Show, Eq, Ord)++-- | 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 normalizedDatatypeInfo 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 = []++mkShortModifiers :: [String] -> [Modifier]+mkShortModifiers fields =+    mapMaybe inner fields+  where+    inner :: String -> Maybe Modifier+    inner field@(short : _) =+      case filter ([short] `isPrefixOf`) fields of+        [_] -> Just $ AddShortOption field short+        _ -> Nothing+    inner [] = Nothing++mkShortOptions :: [Modifier] -> String -> [Char]+mkShortOptions modifiers option =+    mapMaybe inner modifiers+  where+    inner :: Modifier -> Maybe Char+    inner (AddShortOption modifierOption short)+      | matchesField modifierOption option+        = Just short+      | otherwise+        = Nothing+    inner _ = Nothing++mkLongOptions :: [Modifier] -> String -> [String]+mkLongOptions modifiers option =+    inner (reverse modifiers)+  where+    inner (RenameOption renameOption newName : _)+      | renameOption `matchesField` option = [newName]+    inner [] = [option]+    inner (_ : r) = inner r++matchesField :: String -> String -> Bool+matchesField modifierOption option =+  modifierOption == option || slugify modifierOption == option