diff --git a/optparse-generic.cabal b/optparse-generic.cabal --- a/optparse-generic.cabal +++ b/optparse-generic.cabal @@ -1,5 +1,5 @@ Name: optparse-generic -Version: 1.1.0 +Version: 1.1.1 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3 @@ -7,6 +7,7 @@ Copyright: 2016 Gabriel Gonzalez Author: Gabriel Gonzalez Maintainer: Gabriel439@gmail.com +Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 Bug-Reports: https://github.com/Gabriel439/Haskell-Optparse-Generic-Library/issues Synopsis: Auto-generate a command-line parser for your datatype Description: This library auto-generates an @optparse-applicative@-compatible @@ -33,6 +34,7 @@ if impl(ghc < 7.8) Build-Depends: singletons >= 0.10.0 && < 1.0 , - tagged >= 0.8.3 && < 0.9 + tagged >= 0.8.3 && < 0.9 , + th-desugar < 1.5.1 Exposed-Modules: Options.Generic GHC-Options: -Wall diff --git a/src/Options/Generic.hs b/src/Options/Generic.hs --- a/src/Options/Generic.hs +++ b/src/Options/Generic.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -206,14 +207,18 @@ module Options.Generic ( -- * Parsers getRecord + , getRecordPure , ParseRecord(..) , ParseFields(..) , ParseField(..) , Only(..) , getOnly + , Modifiers(..) + , parseRecordWithModifiers + , defaultModifiers -- * Help - , ()(..) + , type ()(..) -- * Re-exports , Generic @@ -520,7 +525,7 @@ class ParseRecord a where parseRecord :: Parser a default parseRecord :: (Generic a, GenericParseRecord (Rep a)) => Parser a - parseRecord = fmap GHC.Generics.to genericParseRecord + parseRecord = fmap GHC.Generics.to (genericParseRecord defaultModifiers) instance ParseFields a => ParseRecord (Only a) @@ -593,30 +598,38 @@ instance (ParseFields a, ParseFields b) => ParseRecord (Either a b) +data Modifiers = Modifiers + { fieldNameModifier :: String -> String + , constructorNameModifier :: String -> String + } + +defaultModifiers :: Modifiers +defaultModifiers = Modifiers id (map toLower) + class GenericParseRecord f where - genericParseRecord :: Parser (f p) + genericParseRecord :: Modifiers -> Parser (f p) instance GenericParseRecord U1 where - genericParseRecord = pure U1 + genericParseRecord _ = pure U1 -- See: [NOTE - Sums] instance GenericParseRecord f => GenericParseRecord (M1 C c f) where - genericParseRecord = fmap M1 genericParseRecord + genericParseRecord = fmap M1 . genericParseRecord -- See: [NOTE - Sums] instance (GenericParseRecord (f :+: g), GenericParseRecord (h :+: i)) => GenericParseRecord ((f :+: g) :+: (h :+: i)) where - genericParseRecord = do - fmap L1 genericParseRecord <|> fmap R1 genericParseRecord + genericParseRecord mods = do + fmap L1 (genericParseRecord mods) <|> fmap R1 (genericParseRecord mods) -- See: [NOTE - Sums] instance (Constructor c, GenericParseRecord f, GenericParseRecord (g :+: h)) => GenericParseRecord (M1 C c f :+: (g :+: h)) where - genericParseRecord = do + genericParseRecord mods@Modifiers{..} = do let m :: M1 i c f a m = undefined - let name = map toLower (conName m) + let name = constructorNameModifier (conName m) - let info = Options.info (Options.helper <*> genericParseRecord) mempty + let info = Options.info (Options.helper <*> (genericParseRecord mods)) mempty let subparserFields = Options.command name info @@ -624,17 +637,17 @@ let parser = Options.subparser subparserFields - fmap (L1 . M1) parser <|> fmap R1 genericParseRecord + fmap (L1 . M1) parser <|> fmap R1 (genericParseRecord mods) -- See: [NOTE - Sums] instance (Constructor c, GenericParseRecord (f :+: g), GenericParseRecord h) => GenericParseRecord ((f :+: g) :+: M1 C c h) where - genericParseRecord = do + genericParseRecord mods@Modifiers{..} = do let m :: M1 i c h a m = undefined - let name = map toLower (conName m) + let name = constructorNameModifier (conName m) - let info = Options.info (Options.helper <*> genericParseRecord) mempty + let info = Options.info (Options.helper <*> (genericParseRecord mods)) mempty let subparserFields = Options.command name info @@ -642,21 +655,21 @@ let parser = Options.subparser subparserFields - fmap L1 genericParseRecord <|> fmap (R1 . M1) parser + fmap L1 (genericParseRecord mods) <|> fmap (R1 . M1) parser -- See: [NOTE - Sums] instance (Constructor c1, Constructor c2, GenericParseRecord f1, GenericParseRecord f2) => GenericParseRecord (M1 C c1 f1 :+: M1 C c2 f2) where - genericParseRecord = do + genericParseRecord mods@Modifiers{..} = do let m1 :: M1 i c1 f a m1 = undefined let m2 :: M1 i c2 g a m2 = undefined - let name1 = map toLower (conName m1) - let name2 = map toLower (conName m2) + let name1 = constructorNameModifier (conName m1) + let name2 = constructorNameModifier (conName m2) - let info1 = Options.info (Options.helper <*> genericParseRecord) mempty - let info2 = Options.info (Options.helper <*> genericParseRecord) mempty + let info1 = Options.info (Options.helper <*> (genericParseRecord mods)) mempty + let info2 = Options.info (Options.helper <*> (genericParseRecord mods)) mempty let subparserFields1 = Options.command name1 info1 @@ -671,19 +684,19 @@ fmap (L1 . M1) parser1 <|> fmap (R1 . M1) parser2 instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :*: g) where - genericParseRecord = liftA2 (:*:) genericParseRecord genericParseRecord + genericParseRecord mods = liftA2 (:*:) (genericParseRecord mods) (genericParseRecord mods) instance GenericParseRecord V1 where - genericParseRecord = empty + genericParseRecord _ = empty instance (Selector s, ParseFields a) => GenericParseRecord (M1 S s (K1 i a)) where - genericParseRecord = do + genericParseRecord Modifiers{..} = do let m :: M1 i s f a m = undefined let label = case (selName m) of "" -> Nothing - name -> Just (Data.Text.pack name) + name -> Just (Data.Text.pack (fieldNameModifier name)) fmap (M1 . K1) (parseFields Nothing label) {- [NOTE - Sums] @@ -752,8 +765,11 @@ -} instance GenericParseRecord f => GenericParseRecord (M1 D c f) where - genericParseRecord = fmap M1 (Options.helper <*> genericParseRecord) + genericParseRecord mods = fmap M1 (Options.helper <*> genericParseRecord mods) +parseRecordWithModifiers :: (Generic a, GenericParseRecord (Rep a)) => Modifiers -> Parser a +parseRecordWithModifiers mods = fmap GHC.Generics.to (genericParseRecord mods) + -- | Marshal any value that implements `ParseRecord` from the command line getRecord :: (MonadIO io, ParseRecord a) @@ -765,3 +781,31 @@ header = Options.header (Data.Text.unpack desc) info = Options.info parseRecord header + +{-| Pure version of `getRecord` + +>>> :set -XOverloadedStrings +>>> getRecordPure ["1"] :: Maybe Int +Just 1 +>>> getRecordPure ["1", "2"] :: Maybe [Int] +Just [1,2] +>>> getRecordPure ["Foo"] :: Maybe Int +Nothing +-} +getRecordPure + :: ParseRecord a + => [Text] + -- ^ Command-line arguments + -> Maybe a +getRecordPure args = do + let prefs = Options.ParserPrefs + { prefMultiSuffix = "" + , prefDisambiguate = False + , prefShowHelpOnError = False + , prefBacktrack = True + , prefColumns = 80 + } + let header = Options.header "" + let info = Options.info parseRecord header + let args' = map Data.Text.unpack args + Options.getParseResult (Options.execParserPure prefs info args')