diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,84 @@ +1.5.3 + +- [Link to code in documentation examples](https://github.com/Gabriella439/optparse-generic/pull/118) +- [Allow newer `optparse-applicative`](https://github.com/Gabriella439/optparse-generic/pull/116) +- [Allow newer `time`](https://github.com/Gabriella439/optparse-generic/pull/115) +- [Allow newer `text`, `bytestring`, and `filepath`](https://github.com/Gabriella439/optparse-generic/pull/113) + +1.5.2 + +* [Add support for `OsPath`](https://github.com/Gabriella439/optparse-generic/pull/111) + +1.5.1 + +* [Add `Eq` instances for `()`, `()`, and `(<#>)`](https://github.com/Gabriella439/optparse-generic/pull/109) + +1.5.0 + +* BREAKING CHANGE: [Drop support for `system-filepath`](https://github.com/Gabriella439/optparse-generic/pull/106) +* [Add support for more `Data.Time` types](https://github.com/Gabriella439/optparse-generic/pull/102) + +1.4.9 + +* [Add `Data` instance for `Unwrapped`](https://github.com/Gabriella439/optparse-generic/pull/100) + +1.4.8 + +* [Improve handling of `NonEmpty`](https://github.com/Gabriella439/optparse-generic/pull/98) +* [Add `getWithHelpWith`](https://github.com/Gabriella439/Haskell-Optparse-Generic-Library/pull/94) +* [Build against `optparse-applicative-0.17`](https://github.com/Gabriella439/Haskell-Optparse-Generic-Library/pull/92) +* [Build against `text-2.0`](https://github.com/Gabriella439/optparse-generic/pull/91) + +1.4.7 + +* [Derive `Data` instances for exported types](https://github.com/Gabriel439/Haskell-Optparse-Generic-Library/pull/89) + +1.4.6 + +* Use `readField` in default implementation of `parseField` + +1.4.5 + +* [Add ability to set the short name in the type](https://github.com/Gabriel439/Haskell-Optparse-Generic-Library/pull/84) +* [Display default values in `--help` output](https://github.com/Gabriel439/Haskell-Optparse-Generic-Library/pull/83) + +1.4.4 + +* `readIntegralBounded`: use `metavar` in error message + +1.4.3 + +* Export internal `readIntegralBounded` utility +* Build against `optparse-applicative-0.16.0.0` + +1.4.2 + +* New `unwrap` function + * This is the underlying utility that powers + `unwrap{Record,RecordPure,WithHelp}` + +1.4.1 + +* Fix broken haddocks + +1.4.0 + +* BREAKING CHANGE: Add support for type-level default values + * This is a breaking change because the various `parse*` typeclass methods + now take an additional argument to support this feature + +1.3.1 + +* Export `GenericParseRecord` and `getRecord{,PureWith}` + +1.3.0 + +* BREAKING CHANGE: New `metavar` method for `ParseField` class + * This field simplifies customizing `ParseField` instances + * Now you usually only need to override `metavar` now or possibly also + `readField`, whereas the default behavior for `parseField` should work + more often + * This is only a breaking change for data types that use the default + implementation of `ParseField` but do not derive `Typeable` + * You can migrate existing code that doesn't compile by just explicitly + specifying what the `metavar` field should be diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016 Gabriel Gonzalez +Copyright (c) 2016 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, @@ -8,7 +8,7 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors + * Neither the name of Gabriella Gonzalez nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/examples/unwrap-options.hs b/examples/unwrap-options.hs new file mode 100644 --- /dev/null +++ b/examples/unwrap-options.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +import Options.Generic + +data Options w = Options + { a :: w ::: Int "Int option" + , b :: w ::: Bool "Bool option" + , c :: w ::: String "String option" + } deriving Generic + +instance ParseRecord (Options Wrapped) +deriving instance Show (Options Unwrapped) + +main :: IO () +main = do + opts <- unwrapRecord "unwrap-example" + print (opts :: Options Unwrapped) diff --git a/examples/unwrap-with-help.hs b/examples/unwrap-with-help.hs new file mode 100644 --- /dev/null +++ b/examples/unwrap-with-help.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +import Options.Generic + +data Options w = Options + { a :: w ::: Int "Int option -- must be divisible by 10" + , b :: w ::: Bool "Bool option" + , c :: w ::: String "String option" + } deriving Generic + +instance ParseRecord (Options Wrapped) +deriving instance Show (Options Unwrapped) + +main :: IO () +main = do + (opts, help) <- unwrapWithHelp "unwrap-example" + if (a opts) `rem` 10 == 0 + then print (opts :: Options Unwrapped) + else help diff --git a/optparse-generic.cabal b/optparse-generic.cabal --- a/optparse-generic.cabal +++ b/optparse-generic.cabal @@ -1,14 +1,14 @@ Name: optparse-generic -Version: 1.1.5 -Cabal-Version: >=1.8.0.2 +Version: 1.5.3 +Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-File: LICENSE -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 +Copyright: 2016 Gabriella Gonzalez +Author: Gabriella Gonzalez +Maintainer: GenuineGabriella@gmail.com +Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 +Bug-Reports: https://github.com/Gabriella439/Haskell-Optparse-Generic-Library/issues Synopsis: Auto-generate a command-line parser for your datatype Description: This library auto-generates an @optparse-applicative@-compatible @Parser@ from any data type that derives the @Generic@ interface. @@ -16,23 +16,29 @@ See the documentation in "Options.Generic" for an example of how to use this library Category: System +Extra-Source-Files: CHANGELOG.md Source-Repository head Type: git - Location: https://github.com/Gabriel439/Haskell-Optparse-Generic-Library + Location: https://github.com/Gabriella439/Haskell-Optparse-Generic-Library Library Hs-Source-Dirs: src Build-Depends: - base >= 4.6 && < 5 , - system-filepath >= 0.3.1 && < 0.5 , - text < 1.3 , - transformers >= 0.2.0.0 && < 0.6 , - optparse-applicative >= 0.12.0 && < 0.14, - time >= 1.5 && < 1.7 , - void < 0.8 , - bytestring < 0.11, - semigroups >= 0.5.0 && < 0.19 + base >= 4.8 && < 5 , + text < 2.2 , + transformers >= 0.2.0.0 && < 0.7 , + transformers-compat >= 0.3 && < 0.8 , + Only < 0.2 , + optparse-applicative >= 0.16.0.0 && < 0.20, + time >= 1.5 && < 1.15, + void < 0.8 , + bytestring < 0.13, + filepath < 1.6 + if impl(ghc < 8.0) + Build-Depends: + semigroups >= 0.5.0 && < 0.20 + if impl(ghc < 7.8) Build-Depends: singletons >= 0.10.0 && < 1.0 , @@ -40,3 +46,22 @@ th-desugar < 1.5.1 Exposed-Modules: Options.Generic GHC-Options: -Wall + Default-Language: Haskell2010 + +executable optparse-generic-example-unwrap-options + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: examples + main-is: unwrap-options.hs + build-depends: + base >= 4.7 && <5, + optparse-generic + +executable optparse-generic-example-unwrap-with-help + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: examples + main-is: unwrap-with-help.hs + build-depends: + base >= 4.7 && <5, + optparse-generic diff --git a/src/Options/Generic.hs b/src/Options/Generic.hs --- a/src/Options/Generic.hs +++ b/src/Options/Generic.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} @@ -20,22 +21,24 @@ -- For example, suppose that you want to parse a record with named fields like -- this: -- --- > -- Example.hs --- > --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Options.Generic --- > --- > data Example = Example { foo :: Int, bar :: Double } --- > deriving (Generic, Show) --- > --- > instance ParseRecord Example --- > --- > main = do --- > x <- getRecord "Test program" --- > print (x :: Example) +-- @ +-- -- Example.hs -- +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- +-- import Options.Generic +-- +-- data Example = Example { foo :: Int, bar :: Double } +-- deriving (Generic, Show) +-- +-- instance 'ParseRecord' Example +-- +-- main = do +-- x <- 'getRecord' "Test program" +-- print (x :: Example) +-- @ +-- -- Named fields translate to flags which you can provide in any order: -- -- > $ stack build optparse-generic @@ -46,39 +49,41 @@ -- -- > $ stack runghc Example.hs -- --help -- > Test program --- > +-- > -- > Usage: Example.hs --foo INT --bar DOUBLE --- > +-- > -- > Available options: -- > -h,--help Show this help text -- -- You can also add help descriptions to each field, like this: -- --- > {-# LANGUAGE DataKinds #-} --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE TypeOperators #-} --- > --- > import Options.Generic --- > --- > data Example = Example --- > { foo :: Int "Documentation for the foo flag" --- > , bar :: Double "Documentation for the bar flag" --- > } deriving (Generic, Show) --- > --- > instance ParseRecord Example --- > --- > main = do --- > x <- getRecord "Test program" --- > print (x :: Example) +-- @ +-- {-# LANGUAGE DataKinds #-} +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE TypeOperators #-} -- +-- import Options.Generic +-- +-- data Example = Example +-- { foo :: Int '' "Documentation for the foo flag" +-- , bar :: Double '' "Documentation for the bar flag" +-- } deriving (Generic, Show) +-- +-- instance 'ParseRecord' Example +-- +-- main = do +-- x <- 'getRecord' "Test program" +-- print (x :: Example) +-- @ +-- -- ... which produces the following @--help@ output: -- -- > $ stack runghc Example.hs -- --help -- > Test program --- > +-- > -- > Usage: Example.hs --foo INT --bar DOUBLE --- > +-- > -- > Available options: -- > -h,--help Show this help text -- > --foo INT Documentation for the foo flag @@ -94,32 +99,58 @@ -- generalize the definition of your record with a parameter 'w', and use -- 'unwrapRecord'. -- --- > {-# LANGUAGE DataKinds #-} --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE FlexibleInstances #-} -- One more extension. --- > {-# LANGUAGE OverloadedStrings #-} --- > {-# LANGUAGE StandaloneDeriving #-} -- To derive Show --- > {-# LANGUAGE TypeOperators #-} --- > --- > import Options.Generic --- > --- > data Example w = Example --- > { foo :: w ::: Int "Documentation for the foo flag" --- > , bar :: w ::: Double "Documentation for the bar flag" --- > } deriving (Generic) --- > --- > instance ParseRecord (Example Wrapped) --- > deriving instance Show (Example Unwrapped) --- > --- > main = do --- > x <- unwrapRecord "Test program" --- > print (x :: Example Unwrapped) +-- @ +-- {-# LANGUAGE DataKinds #-} +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE FlexibleInstances #-} -- One more extension. +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE StandaloneDeriving #-} -- To derive Show +-- {-# LANGUAGE TypeOperators #-} -- --- @Example Unwrapped@ is equivalent to a record type with simple fields: +-- import Options.Generic -- +-- data Example w = Example +-- { foo :: w ::: Int '' "Documentation for the foo flag" +-- , bar :: w ::: Double '' "Documentation for the bar flag" +-- } deriving (Generic) +-- +-- instance 'ParseRecord' (Example 'Wrapped') +-- deriving instance Show (Example 'Unwrapped') +-- +-- main = do +-- x <- 'unwrapRecord' "Test program" +-- print (x :: Example Unwrapped) +-- @ +-- +-- @Example 'Unwrapped'@ is equivalent to a record type with simple fields: +-- -- > $ stack runghc Example.hs -- --foo 1 --bar 2.5 -- > Example {foo = 1, bar = 2.5} -- +-- You can also add default values to each `Read`able field, like this: +-- +-- @ +-- {-# LANGUAGE DataKinds #-} +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE TypeOperators #-} +-- +-- import Options.Generic +-- +-- data Example = Example +-- { foo :: Int '' "1" +-- , bar :: String '' "hello" +-- } deriving (Generic, Show) +-- +-- instance 'ParseRecord' Example +-- +-- main = do +-- x <- 'getRecord' "Test program" +-- print (x :: Example) +-- @ +-- +-- Default values will work alongside help descriptions and unwrapping. +-- -- For the following examples I encourage you to test what @--help@ output they -- generate. -- @@ -158,7 +189,7 @@ -- > Example {switch = True, list = [1,2], optional = Just 1, first = First -- > {getFirst = Just 1}, last = Last {getLast = Just 2}, sum = Sum {getSum = -- > 3}, product = Product {getProduct = 2}} --- > +-- > -- > $ stack runghc Example.hs -- > Example {switch = False, list = [], optional = Nothing, first = First -- > {getFirst = Nothing}, second = Last {getLast = Nothing}, sum = Sum {getSum @@ -181,32 +212,38 @@ -- This library also provides out-of-the-box support for many existing types, -- like tuples and `Either`. -- --- > {-# LANGUAGE DeriveGeneric #-} --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Options.Generic --- > --- > main = do --- > x <- getRecord "Test program" --- > print (x :: Either Double Int) +-- @ +-- {-# LANGUAGE DeriveGeneric #-} +-- {-# LANGUAGE OverloadedStrings #-} -- +-- import Options.Generic +-- +-- main = do +-- x <- 'getRecord' "Test program" +-- print (x :: Either Double Int) +-- @ +-- -- > $ stack runghc Example.hs -- left 1.0 -- > Left 1.0 -- > $ stack runghc Example.hs -- right 2 -- > Right 2 --- --- > main = do --- > x <- getRecord "Test program" --- > print (x :: (Double, Int)) -- +-- @ +-- main = do +-- x <- 'getRecord' "Test program" +-- print (x :: (Double, Int)) +-- @ +-- -- > $ stack runghc Example.hs -- 1.0 2 -- > (1.0,2) -- -- ... and you can also just parse a single value: -- --- > main = do --- > x <- getRecord "Test program" --- > print (x :: Int) +-- @ +-- main = do +-- x <- 'getRecord' "Test program" +-- print (x :: Int) +-- @ -- -- > $ stack runghc Example.hs -- 2 -- > 2 @@ -237,25 +274,61 @@ -- > 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 + , getRecordWith + , getWithHelpWith + , getWithHelp , getRecordPure + , getRecordPureWith , unwrapRecord + , unwrapWithHelp , unwrapRecordPure + , unwrap , ParseRecord(..) , ParseFields(..) , ParseField(..) , Only(..) , getOnly + , readIntegralBounded , Modifiers(..) , parseRecordWithModifiers , defaultModifiers , lispCaseModifiers + , firstLetter + , GenericParseRecord(..) -- * Help , type ()(..) + , type ()(..) + , type (<#>)(..) , type (:::) , Wrapped , Unwrapped @@ -274,30 +347,47 @@ import Control.Applicative import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Except (runExcept) +import Control.Monad.Trans.Reader (runReaderT) import Data.Char (isUpper, toLower, toUpper) +import Data.Data (Data) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Maybe (listToMaybe) import Data.Monoid -import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List.NonEmpty (NonEmpty) import Data.Proxy import Data.Text (Text) +import Data.Time.Format.ISO8601 (ISO8601) +import Data.Tuple.Only (Only(..)) import Data.Typeable (Typeable) import Data.Void (Void) -import Filesystem.Path (FilePath) +import Data.Word (Word8, Word16, Word32, Word64) import GHC.Generics -import Prelude hiding (FilePath) +import Prelude import Options.Applicative (Parser, ReadM) +import Data.Time + ( CalendarDiffDays + , CalendarDiffTime + , Day + , LocalTime + , TimeOfDay + , TimeZone + , UTCTime + , ZonedTime + ) + import qualified Data.Text import qualified Data.Text.Encoding import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding -import qualified Data.Time.Calendar -import qualified Data.Time.Format +import qualified Data.Time.Format.ISO8601 as ISO8601 import qualified Data.Typeable import qualified Data.ByteString import qualified Data.ByteString.Lazy -import qualified Filesystem.Path.CurrentOS as Filesystem -import qualified Options.Applicative as Options -import qualified Options.Applicative.Types as Options +import qualified Options.Applicative as Options +import qualified Options.Applicative.Types as Options +import qualified Options.Applicative.NonEmpty as Options.NonEmpty import qualified Text.Read #if MIN_VERSION_base(4,7,0) @@ -306,12 +396,20 @@ import Data.Singletons.TypeLits #endif +#if MIN_VERSION_base(4,8,0) +import Numeric.Natural (Natural) +#endif + +#if MIN_VERSION_filepath(1,4,100) +import System.OsPath +#endif + auto :: Read a => ReadM a auto = do s <- Options.readerAsk case Text.Read.readMaybe s of Just x -> return x - Nothing -> Options.readerAbort Options.ShowHelpText + Nothing -> Options.readerAbort (Options.ShowHelpText Nothing) {-| A class for all record fields that can be parsed from exactly one option or argument on the command line @@ -327,26 +425,36 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name + -> Maybe String + -- ^ Default value -> Parser a default parseField - :: (Typeable a, Read a) - => Maybe Text + :: Maybe Text -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name + -> Maybe String + -- ^ Default value -> Parser a - parseField h m = do - let metavar = map toUpper (show (Data.Typeable.typeOf (undefined :: a))) + parseField h m c d = do + let proxy = Proxy :: Proxy a case m of Nothing -> do - let fs = Options.metavar metavar - <> maybe mempty (Options.help . Data.Text.unpack) h - Options.argument auto fs + let fs = Options.metavar (metavar proxy) + <> foldMap (Options.help . Data.Text.unpack) h + Options.argument readField fs Just name -> do - let fs = Options.metavar metavar + let fs = Options.metavar (metavar proxy) <> Options.long (Data.Text.unpack name) - <> maybe mempty (Options.help . Data.Text.unpack) h - Options.option auto fs + <> foldMap (Options.help . Data.Text.unpack) h + <> foldMap Options.short c + <> foldMap Options.value (d >>= runReadM readField) + <> foldMap (Options.showDefaultWith . const) d + Options.option readField fs {-| The only reason for this method is to provide a special case for handling `String`s. All other instances should just fall back on the @@ -357,98 +465,175 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name + -> Maybe String + -- ^ Default value -> Parser [a] - parseListOfField h m = many (parseField h m) + parseListOfField h m c d = many (parseField h m c d) + readField :: ReadM a + default readField :: Read a => ReadM a + readField = auto + + metavar :: proxy a -> String + default metavar :: Typeable a => proxy a -> String + metavar _ = map toUpper (show (Data.Typeable.typeOf (undefined :: a))) + +-- | a readMaybe using provided ReadM +runReadM :: ReadM a -> String -> Maybe a +runReadM r s = either (const Nothing) Just $ + runExcept (runReaderT (Options.unReadM r) s) + instance ParseField Bool instance ParseField Double instance ParseField Float -instance ParseField Int instance ParseField Integer instance ParseField Ordering instance ParseField () instance ParseField Void +readIntegralBounded :: forall a. (Integral a, Bounded a, Typeable a, ParseField a) => ReadM a +readIntegralBounded = + auto >>= f + where + f i | i < lower = fail msg + | i > upper = fail msg + | otherwise = pure $ fromInteger i + lower = toInteger (minBound :: a) + upper = toInteger (maxBound :: a) + msg = metavar (Proxy :: Proxy a) <> + " must be within the range [" <> + show lower <> " .. " <> show upper <> "]" + +instance ParseField Int where readField = readIntegralBounded +instance ParseField Int8 where readField = readIntegralBounded +instance ParseField Int16 where readField = readIntegralBounded +instance ParseField Int32 where readField = readIntegralBounded +instance ParseField Int64 where readField = readIntegralBounded +instance ParseField Word8 where readField = readIntegralBounded +instance ParseField Word16 where readField = readIntegralBounded +instance ParseField Word32 where readField = readIntegralBounded +instance ParseField Word64 where readField = readIntegralBounded + +#if MIN_VERSION_base(4,8,0) +instance ParseField Natural where + readField = + auto >>= f + where + f i | i < 0 = fail msg + | otherwise = pure $ fromInteger i + msg = "NATURAL cannot be negative" +#endif + instance ParseField String where parseField = parseHelpfulString "STRING" instance ParseField Char where - parseField h m = do - let metavar = "CHAR" - let readM = do - s <- Options.readerAsk - case s of - [c] -> return c - _ -> Options.readerAbort Options.ShowHelpText - case m of - Nothing -> do - let fs = Options.metavar metavar - <> maybe mempty (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 - Options.option readM fs + metavar _ = "CHAR" + readField = do + s <- Options.readerAsk + case s of + [ch] -> return ch + _ -> Options.readerAbort (Options.ShowHelpText Nothing) parseListOfField = parseHelpfulString "STRING" instance ParseField Any where - parseField h m = Any <$> parseField h m + metavar _ = "ANY" + parseField h m c d = Any <$> parseField h m c d instance ParseField All where - parseField h m = All <$> parseField h m + metavar _ = "ALL" + parseField h m c d = All <$> parseField h m c d -parseHelpfulString :: String -> Maybe Text -> Maybe Text -> Parser String -parseHelpfulString metavar h m = +parseHelpfulString + :: String -> Maybe Text -> Maybe Text -> Maybe Char -> Maybe String -> Parser String +parseHelpfulString metavar_ h m c d = case m of Nothing -> do - let fs = Options.metavar metavar - <> maybe mempty (Options.help . Data.Text.unpack) h + let fs = Options.metavar metavar_ + <> foldMap (Options.help . Data.Text.unpack) h Options.argument Options.str fs Just name -> do - let fs = Options.metavar metavar + 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 + <> foldMap ((Options.showDefault <>) . Options.value) d 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 d = Data.Text.pack <$> parseHelpfulString "TEXT" h m c d instance ParseField Data.ByteString.ByteString where - parseField h m = fmap Data.Text.Encoding.encodeUtf8 (parseField h m) + parseField h m c d = fmap Data.Text.Encoding.encodeUtf8 (parseField h m c d) instance ParseField Data.Text.Lazy.Text where - parseField h m = Data.Text.Lazy.pack <$> parseHelpfulString "TEXT" h m + parseField h m c d = Data.Text.Lazy.pack <$> parseHelpfulString "TEXT" h m c d instance ParseField Data.ByteString.Lazy.ByteString where - parseField h m = fmap Data.Text.Lazy.Encoding.encodeUtf8 (parseField h m) + parseField h m c d = fmap Data.Text.Lazy.Encoding.encodeUtf8 (parseField h m c d) -instance ParseField FilePath where - parseField h m = Filesystem.decodeString <$> parseHelpfulString "FILEPATH" h m +readISO8601Field :: forall a . (ParseField a, ISO8601 a) => ReadM a +readISO8601Field = Options.eitherReader reader + where + reader string = + case ISO8601.iso8601ParseM string of + Nothing -> Left ("expected " <> metavar (Proxy :: Proxy a)) + Just t -> Right t -instance ParseField Data.Time.Calendar.Day where - parseField h m = do - let metavar = "YYYY-MM-DD" - case m of - Nothing -> do - let fs = Options.metavar metavar - <> maybe mempty (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 - Options.option iso8601Day fs - where - iso8601Day = Options.eitherReader - $ runReadS . Data.Time.Format.readSTime - False - Data.Time.Format.defaultTimeLocale - "%F" +instance ParseField CalendarDiffDays where + metavar _ = "PyYmMdD" - runReadS [(day, "")] = Right day - runReadS _ = Left "expected YYYY-MM-DD" + readField = readISO8601Field +instance ParseField Day where + metavar _ = "yyyy-mm-dd" + + readField = readISO8601Field + +instance ParseField UTCTime where + metavar _ = "yyyy-mm-ddThh:mm:ss[.sss]Z" + + readField = readISO8601Field + +instance ParseField CalendarDiffTime where + metavar _ = "PyYmMdDThHmMs[.sss]S" + + readField = readISO8601Field + +instance ParseField TimeZone where + metavar _ = "±hh:mm" + + readField = readISO8601Field + +instance ParseField TimeOfDay where + metavar _ = "hh:mm:ss[.sss]" + + readField = readISO8601Field + +instance ParseField LocalTime where + metavar _ = "yyyy-mm-ddThh:mm:ss[.sss]" + + readField = readISO8601Field + +instance ParseField ZonedTime where + metavar _ = "yyyy-mm-ddThh:mm:ss[.sss]±hh:mm" + + readField = readISO8601Field + +#if MIN_VERSION_filepath(1,4,100) +instance ParseField OsString where + metavar _ = "PATH" + readField = Options.eitherReader reader + where + reader string = + case encodeUtf string of + Left err -> Left ("Invalid PATH: " ++ show err) + Right t -> pure t + +#endif + {-| A class for all types that can be parsed from zero or more arguments/options on the command line @@ -461,65 +646,98 @@ -- ^ Help message -> Maybe Text -- ^ Field label + -> Maybe Char + -- ^ Short name + -> Maybe String + -- ^ Default value -> Parser a - default parseFields :: ParseField a => Maybe Text -> Maybe Text -> Parser a + default parseFields + :: ParseField a => Maybe Text -> Maybe Text -> Maybe Char -> Maybe String -> Parser a parseFields = parseField instance ParseFields Char instance ParseFields Double instance ParseFields Float instance ParseFields Int +instance ParseFields Int8 +instance ParseFields Int16 +instance ParseFields Int32 +instance ParseFields Int64 instance ParseFields Integer instance ParseFields Ordering instance ParseFields Void +instance ParseFields Word8 +instance ParseFields Word16 +instance ParseFields Word32 +instance ParseFields Word64 instance ParseFields Data.ByteString.ByteString instance ParseFields Data.ByteString.Lazy.ByteString instance ParseFields Data.Text.Text instance ParseFields Data.Text.Lazy.Text -instance ParseFields FilePath -instance ParseFields Data.Time.Calendar.Day +instance ParseFields CalendarDiffDays +instance ParseFields Day +instance ParseFields UTCTime +instance ParseFields CalendarDiffTime +instance ParseFields TimeZone +instance ParseFields TimeOfDay +instance ParseFields LocalTime +instance ParseFields ZonedTime +#if MIN_VERSION_filepath(1,4,100) +instance ParseFields OsString +#endif + +#if MIN_VERSION_base(4,8,0) +instance ParseFields Natural +#endif + instance ParseFields Bool where - parseFields h m = + parseFields h m c d = 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 $ + Just name -> case d >>= Text.Read.readMaybe of + Nothing -> 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 + Just d0 -> Options.flag d0 (not d0) $ + Options.long (Data.Text.unpack name) + <> 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 d = (fmap mconcat . many . fmap Any) (parseField h m c d) instance ParseFields All where - parseFields h m = (fmap mconcat . many . fmap All) (parseField h m) + parseFields h m c d = (fmap mconcat . many . fmap All) (parseField h m c d) instance ParseField a => ParseFields (Maybe a) where - parseFields h m = optional (parseField h m) + parseFields h m c d = optional (parseField h m c d) instance ParseField a => ParseFields (First a) where - parseFields h m = (fmap mconcat . many . fmap (First . Just)) (parseField h m) + parseFields h m c d = (fmap mconcat . many . fmap (First . Just)) (parseField h m c d) instance ParseField a => ParseFields (Last a) where - parseFields h m = (fmap mconcat . many . fmap (Last . Just)) (parseField h m) + parseFields h m c d = (fmap mconcat . many . fmap (Last . Just)) (parseField h m c d) instance (Num a, ParseField a) => ParseFields (Sum a) where - parseFields h m = (fmap mconcat . many . fmap Sum) (parseField h m) + parseFields h m c d = (fmap mconcat . many . fmap Sum) (parseField h m c d) instance (Num a, ParseField a) => ParseFields (Product a) where - parseFields h m = (fmap mconcat . many . fmap Product) (parseField h m) + parseFields h m c d = (fmap mconcat . many . fmap Product) (parseField h m c d) 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 d = Options.NonEmpty.some1 (parseField h m c d) {-| Use this to annotate a field with a type-level string (i.e. a `Symbol`) representing the help description for that field: @@ -529,21 +747,62 @@ > , bar :: Double "Documentation for the bar flag" > } deriving (Generic, Show) -} -newtype () (field :: *) (help :: Symbol) = Helpful { unHelpful :: field } deriving (Generic, Show) +newtype () field (help :: Symbol) = Helpful { unHelpful :: field } deriving (Generic, Show, Data, Eq) 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 d = Helpful <$> + parseField ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m c d + readField = Helpful <$> readField + metavar _ = metavar (Proxy :: Proxy a) 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 d = Helpful <$> + parseFields ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m c d instance (ParseFields a, KnownSymbol h) => ParseRecord (a h) +{-| Use this to annotate a field with a type-level string (i.e. a `Symbol`) + representing the default value for that field: + +> data Example = Example +> { foo :: Int "1" +> , bar :: Double "0.5" +> } deriving (Generic, Show) +-} +newtype () field (value :: Symbol) = DefValue { unDefValue :: field } deriving (Generic, Show, Data, Eq) + +instance (ParseField a, KnownSymbol d) => ParseField (a d) where + parseField h m c _ = DefValue <$> parseField h m c (Just (symbolVal (Proxy :: Proxy d))) + readField = DefValue <$> readField + metavar _ = metavar (Proxy :: Proxy a) + +instance (ParseFields a, KnownSymbol d) => ParseFields (a d) where + parseFields h m c _ = DefValue <$> parseFields h m c (Just (symbolVal (Proxy :: Proxy d))) +instance (ParseFields a, KnownSymbol h) => ParseRecord (a h) + +{-| Use this to annotate a field with a type-level char (i.e. a `Symbol`) + representing the short name of the field (only the first character of the + symbol is used): + +> data Example = Example +> { foo :: Int <#> "f" +> , bar :: Double <#> "b" +> } deriving (Generic, Show) +-} +newtype (<#>) field (value :: Symbol) = ShortName { unShortName :: field } deriving (Generic, Show, Data, Eq) + +instance (ParseField a, KnownSymbol c) => ParseField (a <#> c) where + parseField h m _ d = ShortName <$> parseField h m (listToMaybe (symbolVal (Proxy :: Proxy c))) d + readField = ShortName <$> readField + metavar _ = metavar (Proxy :: Proxy a) + +instance (ParseFields a, KnownSymbol c) => ParseFields (a <#> c) where + parseFields h m _ d = ShortName <$> parseFields h m (listToMaybe (symbolVal (Proxy :: Proxy c))) d +instance (ParseFields a, KnownSymbol h) => ParseRecord (a <#> h) + {-| A 1-tuple, used solely to translate `ParseFields` instances into `ParseRecord` instances -} -newtype Only a = Only a deriving (Generic, Show) +newtype Only_ a = Only_ a deriving (Generic, Show) {-| This is a convenience function that you can use if you want to create a `ParseRecord` instance that just defers to the `ParseFields` instance for @@ -572,7 +831,11 @@ default parseRecord :: (Generic a, GenericParseRecord (Rep a)) => Parser a parseRecord = fmap GHC.Generics.to (genericParseRecord defaultModifiers) -instance ParseFields a => ParseRecord (Only a) +instance ParseFields a => ParseRecord (Only_ a) +instance ParseFields a => ParseRecord (Only a) where + parseRecord = fmap adapt parseRecord + where + adapt (Only_ x) = Only x instance ParseRecord Char where parseRecord = fmap getOnly parseRecord @@ -582,10 +845,31 @@ parseRecord = fmap getOnly parseRecord instance ParseRecord Int where parseRecord = fmap getOnly parseRecord +instance ParseRecord Int8 where + parseRecord = fmap getOnly parseRecord +instance ParseRecord Int16 where + parseRecord = fmap getOnly parseRecord +instance ParseRecord Int32 where + parseRecord = fmap getOnly parseRecord +instance ParseRecord Int64 where + parseRecord = fmap getOnly parseRecord instance ParseRecord Ordering instance ParseRecord Void +instance ParseRecord Word8 where + parseRecord = fmap getOnly parseRecord +instance ParseRecord Word16 where + parseRecord = fmap getOnly parseRecord +instance ParseRecord Word32 where + parseRecord = fmap getOnly parseRecord +instance ParseRecord Word64 where + parseRecord = fmap getOnly parseRecord instance ParseRecord () +#if MIN_VERSION_base(4,8,0) +instance ParseRecord Natural where + parseRecord = fmap getOnly parseRecord +#endif + instance ParseRecord Bool where parseRecord = fmap getOnly parseRecord @@ -604,18 +888,41 @@ instance ParseRecord All where parseRecord = fmap getOnly parseRecord -instance ParseRecord FilePath where - parseRecord = fmap getOnly parseRecord - instance ParseRecord Data.ByteString.ByteString where parseRecord = fmap getOnly parseRecord instance ParseRecord Data.ByteString.Lazy.ByteString where parseRecord = fmap getOnly parseRecord -instance ParseRecord Data.Time.Calendar.Day where +instance ParseRecord CalendarDiffDays where parseRecord = fmap getOnly parseRecord +instance ParseRecord Day where + parseRecord = fmap getOnly parseRecord + +instance ParseRecord UTCTime where + parseRecord = fmap getOnly parseRecord + +instance ParseRecord CalendarDiffTime where + parseRecord = fmap getOnly parseRecord + +instance ParseRecord TimeZone where + parseRecord = fmap getOnly parseRecord + +instance ParseRecord TimeOfDay where + parseRecord = fmap getOnly parseRecord + +instance ParseRecord LocalTime where + parseRecord = fmap getOnly parseRecord + +instance ParseRecord ZonedTime where + parseRecord = fmap getOnly parseRecord + +#if MIN_VERSION_filepath(1,4,100) +instance ParseRecord OsString where + parseRecord = fmap getOnly parseRecord +#endif + instance ParseField a => ParseRecord (Maybe a) where parseRecord = fmap getOnly parseRecord @@ -646,13 +953,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 +1012,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 +1113,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 Nothing) {- [NOTE - Sums] @@ -831,22 +1187,85 @@ 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 +-- +-- If you need to modify the top-level 'ParserInfo' or 'ParserPrefs' +-- use the 'getRecordWith' function. getRecord :: (MonadIO io, ParseRecord a) => Text -- ^ Program description -> io a -getRecord desc = liftIO (Options.customExecParser defaultParserPrefs info) +getRecord desc = getRecordWith header mempty where header = Options.header (Data.Text.unpack desc) - info = Options.info parseRecord header +-- | Marshal any value that implements `ParseRecord` from the command line +-- +-- This is the lower-level sibling of 'getRecord and lets you modify +-- the 'ParserInfo' and 'ParserPrefs' records. +getRecordWith + :: (MonadIO io, ParseRecord a) + => Options.InfoMod a + -- ^ 'ParserInfo' modifiers + -> Options.PrefsMod + -- ^ 'ParserPrefs' modifiers + -> io a +getRecordWith infoMods prefsMods = liftIO (Options.customExecParser prefs info) + where + prefs = Options.prefs (defaultParserPrefs <> prefsMods) + info = Options.info parseRecord infoMods + +-- | Marshal any value that implements `ParseRecord` from the command 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 = getWithHelpWith desc mempty + +-- | Marshal any value that implements `ParseRecord` from the command line +-- alongside an io action that prints the help message. +getWithHelpWith + :: (MonadIO io, ParseRecord a) + => Text + -- ^ Program description + -> Options.PrefsMod + -- ^ 'ParserPrefs' modifiers + -> io (a, io ()) + -- ^ (options, io action to print help message) +getWithHelpWith desc prefsMods = do + a <- getRecordWith header prefsMods + return (a, help) + where + header = Options.header (Data.Text.unpack desc) + info = Options.info parseRecord header + help = liftIO (showHelpText (Options.prefs defaultParserPrefs) info) + {-| Pure version of `getRecord` +If you need to modify the parser's 'ParserInfo' or 'ParserPrefs', use +`getRecordPureWith`. + >>> :set -XOverloadedStrings >>> getRecordPure ["1"] :: Maybe Int Just 1 @@ -860,23 +1279,53 @@ => [Text] -- ^ Command-line arguments -> Maybe a -getRecordPure args = do +getRecordPure args = getRecordPureWith args mempty mempty + +{-| Pure version of `getRecordWith` + +Like `getRecordWith`, this is a sibling of 'getRecordPure and +exposes the monoidal modifier structures for 'ParserInfo' and +'ParserPrefs' to you. + +>>> :set -XOverloadedStrings +>>> getRecordPureWith ["1"] mempty mempty :: Maybe Int +Just 1 +>>> getRecordPureWith ["1", "2"] mempty mempty :: Maybe [Int] +Just [1,2] +>>> getRecordPureWith ["Foo"] mempty mempty :: Maybe Int +Nothing +-} +getRecordPureWith + :: ParseRecord a + => [Text] + -- ^ Command-line arguments + -> Options.InfoMod a + -- ^ 'ParserInfo' modifiers + -> Options.PrefsMod + -- ^ 'ParserPrefs' modifiers + -> Maybe a +getRecordPureWith args infoMod prefsMod = do let header = Options.header "" - let info = Options.info parseRecord header + let info = Options.info parseRecord (header <> infoMod) + let prefs = Options.prefs (defaultParserPrefs <> prefsMod) let args' = map Data.Text.unpack args - Options.getParseResult (Options.execParserPure defaultParserPrefs info args') + Options.getParseResult (Options.execParserPure prefs info args') -- | @optparse-generic@'s flavor of options. -defaultParserPrefs :: Options.ParserPrefs -defaultParserPrefs = Options.defaultPrefs - { Options.prefMultiSuffix = "..." - } +defaultParserPrefs :: Options.PrefsMod +defaultParserPrefs = Options.multiSuffix "..." -- | A type family to extract fields wrapped using '()' type family (:::) wrap wrapped type instance Wrapped ::: wrapped = wrapped -type instance Unwrapped ::: (field helper) = field +type instance Unwrapped ::: wrapped = Unwrap wrapped +type family Unwrap ty where + Unwrap (ty helper) = Unwrap ty + Unwrap (ty defVal) = Unwrap ty + Unwrap (ty <#> shrtNm) = Unwrap ty + Unwrap ty = ty + infixr 0 ::: -- | Flag to keep fields wrapped @@ -884,6 +1333,7 @@ -- | Flag to unwrap fields annotated using '()' data Unwrapped + deriving (Data) -- | Constraint for types whose fields can be unwrapped type Unwrappable f = (Generic (f Wrapped), Generic (f Unwrapped), GenericUnwrappable (Rep (f Wrapped)) (Rep (f Unwrapped))) @@ -907,9 +1357,18 @@ instance GenericUnwrappable (K1 i c) (K1 i c) where genericUnwrap = id -instance GenericUnwrappable (K1 i (field helper)) (K1 i field) where - genericUnwrap (K1 c) = K1 (unHelpful c) +instance GenericUnwrappable (K1 i field) (K1 i c) + => GenericUnwrappable (K1 i (field helper)) (K1 i c) where + genericUnwrap (K1 c) = (genericUnwrap :: K1 i field p -> K1 i c p) (K1 (unHelpful c)) +instance GenericUnwrappable (K1 i field) (K1 i c) + => GenericUnwrappable (K1 i (field defVal)) (K1 i c) where + genericUnwrap (K1 c) = (genericUnwrap :: K1 i field p -> K1 i c p) (K1 (unDefValue c)) + +instance GenericUnwrappable (K1 i field) (K1 i c) + => GenericUnwrappable (K1 i (field <#> defVal)) (K1 i c) where + genericUnwrap (K1 c) = (genericUnwrap :: K1 i field p -> K1 i c p) (K1 (unShortName c)) + -- | Unwrap the fields of a constructor unwrap :: forall f . Unwrappable f => f Wrapped -> f Unwrapped unwrap = to . genericUnwrap . from @@ -929,3 +1388,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 Nothing) 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)