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.5 +Version: 1.2.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3 diff --git a/src/Options/Generic.hs b/src/Options/Generic.hs --- a/src/Options/Generic.hs +++ b/src/Options/Generic.hs @@ -237,12 +237,37 @@ -- > In an equation for ‘parseRecord’: -- > parseRecord = Options.Generic.$gdmparseRecord -- > In the instance declaration for ‘ParseRecord TheTypeOfYourRecord’ +-- +-- You can customize the library's default behavior using the +-- `parseRecordWithModifiers` utility, like this: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Options.Generic +-- > +-- > data Example = Example { foo :: Int, bar :: Double } +-- > deriving (Generic, Show) +-- > +-- > modifiers :: Modifiers +-- > modifiers = defaultModifiers +-- > { shortNameModifier = firstLetter +-- > } +-- > +-- > instance ParseRecord Example where +-- > parseRecord = parseRecordWithModifiers modifiers +-- > +-- > main = do +-- > x <- getRecord "Test program" +-- > print (x :: Example) module Options.Generic ( -- * Parsers getRecord + , getWithHelp , getRecordPure , unwrapRecord + , unwrapWithHelp , unwrapRecordPure , ParseRecord(..) , ParseFields(..) @@ -253,6 +278,7 @@ , parseRecordWithModifiers , defaultModifiers , lispCaseModifiers + , firstLetter -- * Help , type ()(..) @@ -275,6 +301,7 @@ import Control.Applicative import Control.Monad.IO.Class (MonadIO(..)) import Data.Char (isUpper, toLower, toUpper) +import Data.Foldable (foldMap) import Data.Monoid import Data.List.NonEmpty (NonEmpty((:|))) import Data.Proxy @@ -327,6 +354,8 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name -> Parser a default parseField :: (Typeable a, Read a) @@ -334,18 +363,21 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name -> Parser a - parseField h m = do + parseField h m c = do let metavar = map toUpper (show (Data.Typeable.typeOf (undefined :: a))) case m of Nothing -> do let fs = Options.metavar metavar - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h Options.argument auto fs Just name -> do let fs = Options.metavar metavar <> Options.long (Data.Text.unpack name) - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h + <> foldMap Options.short c Options.option auto fs {-| The only reason for this method is to provide a special case for @@ -357,8 +389,10 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name -> Parser [a] - parseListOfField h m = many (parseField h m) + parseListOfField h m c = many (parseField h m c) instance ParseField Bool instance ParseField Double @@ -373,71 +407,75 @@ parseField = parseHelpfulString "STRING" instance ParseField Char where - parseField h m = do + parseField h m c = do let metavar = "CHAR" let readM = do s <- Options.readerAsk case s of - [c] -> return c - _ -> Options.readerAbort Options.ShowHelpText + [ch] -> return ch + _ -> Options.readerAbort Options.ShowHelpText case m of Nothing -> do let fs = Options.metavar metavar - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h Options.argument readM fs Just name -> do let fs = Options.metavar metavar <> Options.long (Data.Text.unpack name) - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h + <> foldMap Options.short c Options.option readM fs parseListOfField = parseHelpfulString "STRING" instance ParseField Any where - parseField h m = Any <$> parseField h m + parseField h m c = Any <$> parseField h m c instance ParseField All where - parseField h m = All <$> parseField h m + parseField h m c = All <$> parseField h m c -parseHelpfulString :: String -> Maybe Text -> Maybe Text -> Parser String -parseHelpfulString metavar h m = +parseHelpfulString + :: String -> Maybe Text -> Maybe Text -> Maybe Char -> Parser String +parseHelpfulString metavar h m c = case m of Nothing -> do let fs = Options.metavar metavar - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h Options.argument Options.str fs Just name -> do let fs = Options.metavar metavar <> Options.long (Data.Text.unpack name) - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h + <> foldMap Options.short c Options.option Options.str fs instance ParseField Data.Text.Text where - parseField h m = Data.Text.pack <$> parseHelpfulString "TEXT" h m + parseField h m c = Data.Text.pack <$> parseHelpfulString "TEXT" h m c instance ParseField Data.ByteString.ByteString where - parseField h m = fmap Data.Text.Encoding.encodeUtf8 (parseField h m) + parseField h m c = fmap Data.Text.Encoding.encodeUtf8 (parseField h m c) instance ParseField Data.Text.Lazy.Text where - parseField h m = Data.Text.Lazy.pack <$> parseHelpfulString "TEXT" h m + parseField h m c = Data.Text.Lazy.pack <$> parseHelpfulString "TEXT" h m c instance ParseField Data.ByteString.Lazy.ByteString where - parseField h m = fmap Data.Text.Lazy.Encoding.encodeUtf8 (parseField h m) + parseField h m c = fmap Data.Text.Lazy.Encoding.encodeUtf8 (parseField h m c) instance ParseField FilePath where - parseField h m = Filesystem.decodeString <$> parseHelpfulString "FILEPATH" h m + parseField h m c = Filesystem.decodeString <$> parseHelpfulString "FILEPATH" h m c instance ParseField Data.Time.Calendar.Day where - parseField h m = do + parseField h m c = do let metavar = "YYYY-MM-DD" case m of Nothing -> do let fs = Options.metavar metavar - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h Options.argument iso8601Day fs Just name -> do let fs = Options.metavar metavar <> Options.long (Data.Text.unpack name) - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h + <> foldMap Options.short c Options.option iso8601Day fs where iso8601Day = Options.eitherReader @@ -461,8 +499,11 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name -> Parser a - default parseFields :: ParseField a => Maybe Text -> Maybe Text -> Parser a + default parseFields + :: ParseField a => Maybe Text -> Maybe Text -> Maybe Char -> Parser a parseFields = parseField instance ParseFields Char @@ -480,46 +521,47 @@ instance ParseFields Data.Time.Calendar.Day instance ParseFields Bool where - parseFields h m = + parseFields h m c = case m of Nothing -> do let fs = Options.metavar "BOOL" - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h Options.argument auto fs Just name -> do Options.switch $ Options.long (Data.Text.unpack name) - <> maybe mempty (Options.help . Data.Text.unpack) h + <> foldMap (Options.help . Data.Text.unpack) h + <> foldMap Options.short c instance ParseFields () where - parseFields _ _ = pure () + parseFields _ _ _ = pure () instance ParseFields Any where - parseFields h m = (fmap mconcat . many . fmap Any) (parseField h m) + parseFields h m c = (fmap mconcat . many . fmap Any) (parseField h m c) instance ParseFields All where - parseFields h m = (fmap mconcat . many . fmap All) (parseField h m) + parseFields h m c = (fmap mconcat . many . fmap All) (parseField h m c) instance ParseField a => ParseFields (Maybe a) where - parseFields h m = optional (parseField h m) + parseFields h m c = optional (parseField h m c) instance ParseField a => ParseFields (First a) where - parseFields h m = (fmap mconcat . many . fmap (First . Just)) (parseField h m) + parseFields h m c = (fmap mconcat . many . fmap (First . Just)) (parseField h m c) instance ParseField a => ParseFields (Last a) where - parseFields h m = (fmap mconcat . many . fmap (Last . Just)) (parseField h m) + parseFields h m c = (fmap mconcat . many . fmap (Last . Just)) (parseField h m c) instance (Num a, ParseField a) => ParseFields (Sum a) where - parseFields h m = (fmap mconcat . many . fmap Sum) (parseField h m) + parseFields h m c = (fmap mconcat . many . fmap Sum) (parseField h m c) instance (Num a, ParseField a) => ParseFields (Product a) where - parseFields h m = (fmap mconcat . many . fmap Product) (parseField h m) + parseFields h m c = (fmap mconcat . many . fmap Product) (parseField h m c) instance ParseField a => ParseFields [a] where parseFields = parseListOfField instance ParseField a => ParseFields (NonEmpty a) where - parseFields h m = (:|) <$> parseField h m <*> parseListOfField h m + parseFields h m c = (:|) <$> parseField h m c <*> parseListOfField h m c {-| Use this to annotate a field with a type-level string (i.e. a `Symbol`) representing the help description for that field: @@ -532,12 +574,12 @@ newtype () (field :: *) (help :: Symbol) = Helpful { unHelpful :: field } deriving (Generic, Show) instance (ParseField a, KnownSymbol h) => ParseField (a h) where - parseField _ m = Helpful <$> - parseField ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m + parseField _ m c = Helpful <$> + parseField ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m c instance (ParseFields a, KnownSymbol h) => ParseFields (a h) where - parseFields _ m = Helpful <$> - parseFields ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m + parseFields _ m c = Helpful <$> + parseFields ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m c instance (ParseFields a, KnownSymbol h) => ParseRecord (a h) {-| A 1-tuple, used solely to translate `ParseFields` instances into @@ -646,13 +688,54 @@ instance (ParseFields a, ParseFields b) => ParseRecord (Either a b) +{-| Options for customizing derived `ParseRecord` implementations for `Generic` + types + + You can either create the `Modifiers` record directly: + + > modifiers :: Modifiers + > modifiers = Modifiers + > { fieldNameModifier = ... + > , constructorNameModifier = ... + > , shortNameModifier = ... + > } + + ... or you can tweak the `defaultModifiers`: + + > modifiers :: Modifiers + > modifiers = defaultModifiers { fieldNameModifier = ... } + + ... or you can use/tweak a predefined `Modifier`, like `lispCaseModifiers` + + The `parseRecordWithModifiers` function uses this `Modifiers` record when + generating a `Generic` implementation of `ParseRecord` +-} data Modifiers = Modifiers { fieldNameModifier :: String -> String + -- ^ Transform the name of derived fields (Default: @id@) , constructorNameModifier :: String -> String + -- ^ Transform the name of derived constructors (Default: @map toLower@) + , shortNameModifier :: String -> Maybe Char + -- ^ Derives an optional short name from the field name (Default: @\\_ -> Nothing@) } +{-| These are the default modifiers used if you derive a `Generic` + implementation. You can customize this and pass the result to + `parseRecordWithModifiers` if you would like to modify the derived + implementation: + + > myModifiers :: Modifiers + > myModifiers = defaultModifiers { constructorNameModifier = id } + > + > instance ParseRecord MyType where + > parseRecord = parseRecordWithModifiers myModifiers +-} defaultModifiers :: Modifiers -defaultModifiers = Modifiers id (map toLower) +defaultModifiers = Modifiers + { fieldNameModifier = id + , constructorNameModifier = map toLower + , shortNameModifier = \_ -> Nothing + } -- | Convert field and constructor names from @CamelCase@ to @lisp-case@. -- @@ -664,12 +747,19 @@ -- > _type -> --type -- > _splitAt -> --split-at lispCaseModifiers :: Modifiers -lispCaseModifiers = Modifiers lispCase lispCase +lispCaseModifiers = Modifiers lispCase lispCase (\_ -> Nothing) where lispCase = dropWhile (== '-') . (>>= lower) . dropWhile (== '_') lower c | isUpper c = ['-', toLower c] | otherwise = [c] +{-| Use this for the `shortNameModifier` field of the `Modifiers` record if + you want to use the first letter of each option as the short name +-} +firstLetter :: String -> Maybe Char +firstLetter (c:_) = Just c +firstLetter _ = Nothing + class GenericParseRecord f where genericParseRecord :: Modifiers -> Parser (f p) @@ -758,10 +848,11 @@ let m :: M1 i s f a m = undefined - let label = case (selName m) of + let label = case selName m of "" -> Nothing name -> Just (Data.Text.pack (fieldNameModifier name)) - fmap (M1 . K1) (parseFields Nothing label) + let shortName = shortNameModifier (selName m) + fmap (M1 . K1) (parseFields Nothing label shortName) {- [NOTE - Sums] @@ -831,7 +922,21 @@ instance GenericParseRecord f => GenericParseRecord (M1 D c f) where genericParseRecord mods = fmap M1 (Options.helper <*> genericParseRecord mods) -parseRecordWithModifiers :: (Generic a, GenericParseRecord (Rep a)) => Modifiers -> Parser a +{-| Use `parseRecordWithModifiers` when you want to tweak the behavior of a + derived `ParseRecord` implementation, like this: + + > myModifiers :: Modifiers + > myModifiers = defaultModifiers { constructorNameModifier = id } + > + > instance ParseRecord MyType where + > parseRecord = parseRecordWithModifiers myModifiers + + This will still require that you derive `Generic` for your type to automate + most of the implementation, but the `Modifiers` that you pass will change + how the implementation generates the command line interface +-} +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 @@ -845,6 +950,22 @@ header = Options.header (Data.Text.unpack desc) info = Options.info parseRecord header +-- | Marshal any value that implements `ParseRecord` from the commmand line +-- alongside an io action that prints the help message. +getWithHelp + :: (MonadIO io, ParseRecord a) + => Text + -- ^ Program description + -> io (a, io ()) + -- ^ (options, io action to print help message) +getWithHelp desc = do + a <- liftIO (Options.customExecParser defaultParserPrefs info) + return (a, help) + where + header = Options.header (Data.Text.unpack desc) + info = Options.info parseRecord header + help = liftIO (showHelpText defaultParserPrefs info) + {-| Pure version of `getRecord` >>> :set -XOverloadedStrings @@ -929,3 +1050,20 @@ -- ^ Command-line arguments -> Maybe (f Unwrapped) unwrapRecordPure = fmap unwrap . getRecordPure + +showHelpText :: Options.ParserPrefs -> Options.ParserInfo a -> IO () +showHelpText pprefs pinfo = + Options.handleParseResult . Options.Failure $ + Options.parserFailure pprefs pinfo Options.ShowHelpText mempty + +-- | Marshal any value that implements 'ParseRecord' from the command line +-- and unwrap its fields alongside an io action to print the help message +unwrapWithHelp + :: (MonadIO io, ParseRecord (f Wrapped), Unwrappable f) + => Text + -- ^ Program description + -> io (f Unwrapped, io ()) + -- ^ (options, io action to print help message) +unwrapWithHelp desc = do + (opts, help) <- getWithHelp desc + return (unwrap opts, help)