getopt-generics 0.3 → 0.4

raw patch · 5 files changed

+258/−129 lines, 5 filesdep +QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

API changes (from Hackage documentation)

Files

• getopt-generics.cabal +4/−2
• src/System/Console/GetOpt/Generics.hs +114/−86
• src/System/Console/GetOpt/Generics/Internal.hs +52/−20
• src/System/Console/GetOpt/Generics/Modifier.hs +49/−21
• src/System/Console/GetOpt/Generics/Result.hs +39/−0

@@ -1,6 +1,6 @@ -- This file has been generated from package.yaml by Cabalize. name: getopt-generics-version: 0.3+version: 0.4 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>.@@ -24,6 +24,7 @@   other-modules:       System.Console.GetOpt.Generics.Internal       System.Console.GetOpt.Generics.Modifier+      System.Console.GetOpt.Generics.Result   build-depends:       base == 4.*     , base-compat >= 0.7@@ -37,7 +38,8 @@   hs-source-dirs: src, test, examples   main-is: Spec.hs   build-depends:-      base == 4.*+      QuickCheck+    , base == 4.*     , base-compat >= 0.7     , generics-sop     , hspec

@@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE DeriveFunctor         #-} {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-}@@ -9,6 +10,7 @@ {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE ViewPatterns          #-} @@ -35,8 +37,11 @@ import           Prelude () import           Prelude.Compat +import           Control.Monad (when) import           Data.Char import           Data.List+import           Data.Maybe+import           Data.Typeable import           Generics.SOP import           System.Console.GetOpt.Compat import           System.Environment@@ -46,6 +51,7 @@  import           System.Console.GetOpt.Generics.Modifier import           System.Console.GetOpt.Generics.Internal+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.@@ -76,111 +82,128 @@       mapM_ (hPutStrLn stderr) errs       exitWith $ ExitFailure 1 --- | 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 (mkModifiers -> modifiers) args = case normalizedDatatypeInfo (Proxy :: Proxy a) of-    ADT typeName _ (constructorInfo :* Nil) ->-      case constructorInfo of-        (Record _ fields) -> processFields header modifiers args fields-        Constructor{} ->-          err typeName "constructors without field labels"-        Infix{} ->-          err typeName "infix constructors"-    ADT typeName _ Nil ->-      err typeName "empty data types"-    ADT typeName _ (_ :* _ :* _) ->-      err typeName "sum-types"-    Newtype _ _ (Record _ fields) ->-      processFields header modifiers args fields-    Newtype typeName _ (Constructor _) ->-      err typeName "constructors without field labels"+parseArguments header modifiersList args = do+    (modifiers, datatypeInfo) <- (,) <$>+      mkModifiers modifiersList <*>+      normalizedDatatypeInfo (Proxy :: Proxy a)+    case datatypeInfo of+      ADT typeName _ (constructorInfo :* Nil) ->+        case constructorInfo of+          (Record _ fields) -> processFields header modifiers args fields+          Constructor{} ->+            err typeName "constructors without field labels"+          Infix{} ->+            err typeName "infix constructors"+      ADT typeName _ Nil ->+        err typeName "empty data types"+      ADT typeName _ (_ :* _ :* _) ->+        err typeName "sum-types"+      Newtype _ _ (Record _ fields) ->+        processFields header modifiers args fields+      Newtype typeName _ (Constructor _) ->+        err typeName "constructors without field labels"   where     err typeName message =-      Errors ["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) =>+processFields :: forall a xs .+  (Generic a, Code a ~ '[xs], SingI xs, All Option xs) =>   String -> Modifiers -> [String] -> NP FieldInfo xs -> Result a processFields header modifiers args fields =-  helpWrapper header modifiers args fields $-  fmap (to . SOP . Z) $-  case getOpt Permute (mkOptDescrs modifiers fields) args of-    (options, arguments, parseErrors) ->-      let result :: Either [String] (NP I xs) =-            collectErrors $ project options (mkEmptyArguments fields)-          allErrors =-            parseErrors ++-            map mkUnknownArgumentError arguments ++-            ignoreRight result-      in case allErrors of-        [] -> result-        _ -> Left allErrors+    mkInitialFieldStates modifiers fields >>= \ initialFieldStates ->++    showHelp *>++    let (options, arguments, parseErrors) =+          getOpt Permute (mkOptDescrs modifiers fields) args+    in++    reportParseErrors parseErrors *>++    reportInvalidPositionalArguments arguments *>++    produceResult initialFieldStates options arguments   where-    mkUnknownArgumentError :: String -> String-    mkUnknownArgumentError arg = "unknown argument: " ++ arg+    showHelp :: Result ()+    showHelp = helpWrapper header modifiers args fields -    ignoreRight :: Monoid e => Either e o -> e-    ignoreRight = either id (const mempty)+    reportParseErrors :: [String] -> Result ()+    reportParseErrors parseErrors = case parseErrors of+      [] -> pure ()+      errs -> Errors errs +    reportInvalidPositionalArguments :: [String] -> Result ()+    reportInvalidPositionalArguments arguments =+      when (not $ hasPositionalArgumentsField modifiers) $+        case arguments of+          [] -> pure ()+          _ -> Errors (map ("unknown argument: " ++) arguments)++    produceResult :: NP FieldState xs -> [NS FieldState xs] -> [String] -> Result a+    produceResult initialFieldStates options arguments =+      (to . SOP . Z) <$>+        collectResult arguments (project options initialFieldStates)++ mkOptDescrs :: forall xs . All Option xs =>   Modifiers -> NP FieldInfo xs -> [OptDescr (NS FieldState xs)] mkOptDescrs modifiers fields =-  map toOptDescr $ sumList $ npMap (mkOptDescr modifiers) fields+  mapMaybe toOptDescr $ sumList $ npMap (mkOptDescr modifiers) fields -newtype OptDescrE a = OptDescrE (OptDescr (FieldState a))+newtype OptDescrE a = OptDescrE (Maybe (OptDescr (FieldState a)))  mkOptDescr :: forall a . Option a => Modifiers -> FieldInfo a -> OptDescrE a mkOptDescr modifiers (FieldInfo name) = OptDescrE $-  Option-    (mkShortOptions modifiers name)-    [mkLongOption modifiers name]-    _toOption-    ""+  if isPositionalArgumentsField modifiers name+    then Nothing+    else Just $ Option+      (mkShortOptions modifiers name)+      [mkLongOption modifiers name]+      _toOption+      "" -toOptDescr :: NS OptDescrE xs -> OptDescr (NS FieldState xs)-toOptDescr (Z (OptDescrE a)) = fmap Z a-toOptDescr (S a) = fmap S (toOptDescr a)+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) -mkEmptyArguments :: forall xs . (SingI xs, All Option xs) =>-  NP FieldInfo xs -> NP FieldState xs-mkEmptyArguments fields = case (sing :: Sing xs, fields) of-  (SNil, Nil) -> Nil+mkInitialFieldStates :: forall xs . (SingI xs, All Option xs) =>+  Modifiers -> NP FieldInfo xs -> Result (NP FieldState xs)+mkInitialFieldStates modifiers fields = case (sing :: Sing xs, fields) of+  (SNil, Nil) -> return Nil   (SCons, FieldInfo name :* r) ->-    _emptyOption name :* mkEmptyArguments r+    (:*) <$> inner name <*> mkInitialFieldStates modifiers r   _ -> uninhabited "mkEmpty" + where+  inner :: forall x . Option x => String -> 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)) ->+        return $ id' PositionalArguments+      Nothing -> Errors+        ["UseForPositionalArguments can only be used " +++         "for fields of type [String] not " +++         show (typeOf (impossible "mkInitialFieldStates" :: x))]+    else return $ _emptyOption name + -- * showing help?  data HelpFlag = HelpFlag  helpWrapper :: (All Option xs) =>-  String -> Modifiers -> [String] -> NP FieldInfo xs -> Either [String] a -> Result a-helpWrapper header modifiers args fields result =+  String -> Modifiers -> [String] -> NP FieldInfo xs -> Result ()+helpWrapper header modifiers args fields =     case getOpt Permute [helpOption] args of-      ([], _, _) -> case result of+      ([], _, _) -> return ()         -- no help flag given-        Left errs -> Errors errs-        Right a -> Success a       (HelpFlag : _, _, _) -> OutputAndExit $         stripTrailingSpaces $         usageInfo header $@@ -200,14 +223,16 @@  -- * 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-    (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)-    (FieldSuccess _, Left errs) -> Left errs+collectResult :: [String] -> NP FieldState xs -> Result (NP I xs)+collectResult positionalArguments np = case np of+  Nil -> Success Nil+  (a :* r) -> (:*) <$> inner a <*> collectResult positionalArguments r+  where+    inner :: FieldState a -> Result (I a)+    inner (FieldSuccess v) = Success (I v)+    inner (ParseErrors errs) = Errors errs+    inner (Unset err) = Errors [err]+    inner PositionalArguments = Success (I positionalArguments)  npMap :: (All Option xs) => (forall a . Option a => f a -> g a) -> NP f xs -> NP g xs npMap _ Nil = Nil@@ -236,11 +261,12 @@  -- * possible field types -data FieldState a-  = Unset String-  | ParseErrors [String]-  | FieldSuccess a-  deriving (Functor)+data FieldState a where+  Unset :: String -> FieldState a+  ParseErrors :: [String] -> FieldState a+  FieldSuccess :: a -> FieldState a+  PositionalArguments :: FieldState [String]+  deriving (Typeable)  -- | Type class for all allowed field types. --@@ -250,7 +276,7 @@ -- --   (Unfortunately implementing instances for lists or 'Maybe's of custom types --   is not very straightforward.)-class Option a where+class Typeable a => Option a where   {-# MINIMAL argumentType, parseArgument #-}   -- | Name of the argument type, e.g. "bool" or "integer".   argumentType :: Proxy a -> String@@ -279,11 +305,13 @@  combine :: Option a => FieldState a -> FieldState a -> FieldState a combine _ (Unset _) = impossible "combine"+combine _ PositionalArguments = impossible "combine" combine (ParseErrors e) (ParseErrors f) = ParseErrors (e ++ f) combine (ParseErrors e) _ = ParseErrors e combine (Unset _) x = x combine (FieldSuccess _) (ParseErrors e) = ParseErrors e combine (FieldSuccess a) (FieldSuccess b) = FieldSuccess (_accumulate a b)+combine PositionalArguments _ = PositionalArguments  instance Option Bool where   argumentType _ = "bool"

@@ -1,31 +1,63 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE RankNTypes      #-}+{-# LANGUAGE TypeFamilies    #-}  module System.Console.GetOpt.Generics.Internal where +import           Control.Applicative import           Data.Char import           Generics.SOP +import           System.Console.GetOpt.Generics.Result+ normalizedDatatypeInfo :: (HasDatatypeInfo a, Code a ~ xss, SingI xss) =>-  Proxy a -> DatatypeInfo xss-normalizedDatatypeInfo p = mapFieldInfo (\ (FieldInfo s) -> FieldInfo (slugify s)) (datatypeInfo p)+  Proxy a -> Result (DatatypeInfo xss)+normalizedDatatypeInfo p =+  mapFieldInfoM+    (\ (FieldInfo s) -> FieldInfo <$> normalizeFieldName 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)+mapFieldInfoM :: (SingI xss, Applicative m) =>+     (forall a . FieldInfo a -> m (FieldInfo a))+  -> DatatypeInfo xss -> m (DatatypeInfo xss)+mapFieldInfoM f info = case info of+    (ADT mod name constructors) ->+      ADT mod name <$> (mapConsInfo (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 :: forall m xs . (Applicative m) =>+         (forall a . FieldInfo a -> m (FieldInfo a))+      -> ConstructorInfo xs -> m (ConstructorInfo xs)     mapSingleCons f c = case c of-      (Record name fields) -> Record name (hliftA f fields)-      cons@Infix{} -> cons-      cons@Constructor{} -> cons+      (Record name fields) -> Record name <$> (mapFieldInfo f fields)+      cons@Infix{} -> pure cons+      cons@Constructor{} -> pure cons -slugify :: String -> String-slugify [] = []-slugify (x : xs)-  | isUpper x = '-' : toLower x : slugify xs-  | otherwise = x : slugify xs+    mapConsInfo :: forall m xs . Applicative m =>+         (forall a . ConstructorInfo a -> m (ConstructorInfo a))+      -> NP ConstructorInfo xs -> m (NP ConstructorInfo xs)+    mapConsInfo _ Nil = pure Nil+    mapConsInfo f (a :* r) = (:*) <$> f a <*> mapConsInfo f r++    mapFieldInfo :: forall m xs . Applicative m =>+         (forall a . FieldInfo a -> m (FieldInfo a))+      -> NP FieldInfo xs -> m (NP FieldInfo xs)+    mapFieldInfo _ Nil = pure Nil+    mapFieldInfo f (a :* r) = (:*) <$> f a <*> mapFieldInfo f r++normalizeFieldName :: String -> Result String+normalizeFieldName s =+    let normalized = dropWhile (== '-') $+          filter (\ c -> (isAscii c && isAlpha c) || (c == '-')) s+    in case normalized of+      "" -> Errors ["unsupported field name: " ++ s]+      x -> Success $ slugify x+  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

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs            #-}+{-# LANGUAGE TupleSections    #-}  module System.Console.GetOpt.Generics.Modifier (   Modifier(..),@@ -7,18 +8,24 @@   mkModifiers,   mkShortOptions,   mkLongOption,+  hasPositionalArgumentsField,+  isPositionalArgumentsField,    deriveShortOptions,    -- exported for testing+  mkShortModifiers,   insertWith,  ) where -import           Data.List                               (foldl', isPrefixOf)+import           Control.Applicative+import           Control.Monad+import           Data.Char import           Data.Maybe import           Generics.SOP  import           System.Console.GetOpt.Generics.Internal+import           System.Console.GetOpt.Generics.Result  -- | 'Modifier's can be used to customize the command line parser. data Modifier@@ -28,32 +35,47 @@   | RenameOption String String     -- ^ @RenameOption fieldName customName@ renames the option generated     --   through the @fieldName@ by @customName@.+  | UseForPositionalArguments String   deriving (Show, Eq, Ord)  data Modifiers = Modifiers {   _shortOptions :: [(String, [Char])],-  _renamings :: [(String, String)]+  _renamings :: [(String, String)],+  positionalArgumentsField :: Maybe String  }+ deriving (Show, Eq, Ord) -mkModifiers :: [Modifier] -> Modifiers-mkModifiers = foldl' inner (Modifiers [] [])+mkModifiers :: [Modifier] -> Result Modifiers+mkModifiers = foldM inner (Modifiers [] [] Nothing)   where-    inner :: Modifiers -> Modifier -> Modifiers-    inner (Modifiers shorts renamings) (AddShortOption option short) =-      Modifiers-        (insertWith (++) (slugify option) [short] shorts)-        renamings-    inner (Modifiers shorts renamings) (RenameOption from to) =-      Modifiers shorts (insert (slugify from) to renamings)+    inner :: Modifiers -> Modifier -> Result Modifiers+    inner (Modifiers shorts renamings args) (AddShortOption option short) = do+      normalized <- normalizeFieldName option+      return $ Modifiers+        (insertWith (++) normalized [short] shorts)+        renamings args+    inner (Modifiers shorts renamings args) (RenameOption from to) = do+      fromNormalized <- normalizeFieldName from+      return $ Modifiers shorts (insert fromNormalized to renamings) args+    inner (Modifiers shorts renamings _) (UseForPositionalArguments option) = do+      normalized <- normalizeFieldName option+      return $ Modifiers shorts renamings (Just normalized)  mkShortOptions :: Modifiers -> String -> [Char]-mkShortOptions (Modifiers shortMap _) option =+mkShortOptions (Modifiers shortMap _ _) option =     fromMaybe [] (lookup option shortMap)  mkLongOption :: Modifiers -> String -> String-mkLongOption (Modifiers _ renamings) option =+mkLongOption (Modifiers _ renamings _) option =   fromMaybe option (lookup option renamings) +hasPositionalArgumentsField :: Modifiers -> Bool+hasPositionalArgumentsField = isJust . positionalArgumentsField++isPositionalArgumentsField :: Modifiers -> String -> Bool+isPositionalArgumentsField modifiers field =+  Just field == positionalArgumentsField modifiers+ -- * deriving Modifiers  -- | Derives 'AddShortOption's for all fields of the datatype that start with a@@ -65,7 +87,7 @@  flags :: (SingI (Code a), HasDatatypeInfo a) =>   Proxy a -> [String]-flags proxy = case normalizedDatatypeInfo proxy of+flags proxy = case datatypeInfo proxy of     ADT _ _ ci -> fromNPConstructorInfo ci     Newtype _ _ ci -> fromConstructorInfo ci   where@@ -86,14 +108,20 @@  mkShortModifiers :: [String] -> [Modifier] mkShortModifiers fields =-    mapMaybe inner 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-    inner :: String -> Maybe Modifier-    inner field@(short : _) =-      case filter ([short] `isPrefixOf`) fields of-        [_] -> Just $ AddShortOption field short-        _ -> Nothing-    inner [] = Nothing+    toShort :: String -> Maybe Char+    toShort s = case dropWhile (\ c -> not (isAscii c && isAlpha c)) s of+      [] -> Nothing+      (a : _) -> Just (toLower a)  -- * list utils to replace Data.Map 

@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveFunctor #-}++module System.Console.GetOpt.Generics.Result where++import           Control.Applicative++-- | 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++  (>>) = (*>)