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.0.1 +Version: 1.1.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3 @@ -27,7 +27,12 @@ text < 1.3 , transformers >= 0.2.0.0 && < 0.6 , optparse-applicative >= 0.11.0 && < 0.13, - time >= 1.5 && < 1.7, - void < 0.8 + time >= 1.5 && < 1.7 , + void < 0.8 , + bytestring < 0.11 + if impl(ghc < 7.8) + Build-Depends: + singletons >= 0.10.0 && < 1.0 , + tagged >= 0.8.3 && < 0.9 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 @@ -1,9 +1,12 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | This library auto-generates command-line parsers for data types using -- Haskell's built-in support for generic programming. The best way to @@ -44,6 +47,44 @@ -- > 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) +-- +-- ... 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 +-- > --bar DOUBLE Documentation for the bar flag +-- +-- However, any fields you document will be wrapped in the `Helpful` +-- constructor: +-- +-- > $ stack runghc Example.hs -- --foo 1 --bar 2.5 +-- > Example {foo = Helpful {unHelpful = 1}, bar = Helpful {unHelpful = 2.5}} +-- -- For the following examples I encourage you to test what @--help@ output they -- generate. -- @@ -71,13 +112,13 @@ -- -- This gives the following behavior: -- --- > $ stack runghc Example.hs -- \ --- > --switch \ --- > --optional 1 \ --- > --list 1 --list 2 \ --- > --first 1 --first 2 \ --- > --last 1 --last 2 \ --- > --sum 1 --sum 2 \ +-- > $ stack runghc Example.hs -- +-- > --switch +-- > --optional 1 +-- > --list 1 --list 2 +-- > --first 1 --first 2 +-- > --last 1 --last 2 +-- > --sum 1 --sum 2 -- > --product 1 --product 2 -- > Example {switch = True, list = [1,2], optional = Just 1, first = First -- > {getFirst = Just 1}, last = Last {getLast = Just 2}, sum = Sum {getSum = @@ -171,6 +212,9 @@ , Only(..) , getOnly + -- * Help + , ()(..) + -- * Re-exports , Generic , Text @@ -186,6 +230,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Char (toLower, toUpper) import Data.Monoid +import Data.Proxy import Data.Text (Text) import Data.Typeable (Typeable) import Data.Void (Void) @@ -195,15 +240,25 @@ import Options.Applicative (Parser, ReadM) 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.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 Text.Read +#if MIN_VERSION_base(4,7,0) +import GHC.TypeLits +#else +import Data.Singletons.TypeLits +#endif + auto :: Read a => ReadM a auto = do s <- Options.readerAsk @@ -222,18 +277,28 @@ class ParseField a where parseField :: Maybe Text + -- ^ Help message + -> Maybe Text -- ^ Field label -> Parser a - default parseField :: (Typeable a, Read a) => Maybe Text -> Parser a - parseField m = do + default parseField + :: (Typeable a, Read a) + => Maybe Text + -- ^ Help message + -> Maybe Text + -- ^ Field label + -> Parser a + parseField h m = 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 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 Options.option auto fs {-| The only reason for this method is to provide a special case for @@ -242,9 +307,11 @@ -} parseListOfField :: Maybe Text + -- ^ Help message + -> Maybe Text -- ^ Field label -> Parser [a] - parseListOfField = fmap many parseField + parseListOfField h m = many (parseField h m) instance ParseField Bool instance ParseField Double @@ -256,10 +323,10 @@ instance ParseField Void instance ParseField String where - parseField = parseString "STRING" + parseField = parseHelpfulString "STRING" instance ParseField Char where - parseField m = do + parseField h m = do let metavar = "CHAR" let readM = do s <- Options.readerAsk @@ -269,49 +336,61 @@ 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 - parseListOfField = parseString "STRING" + parseListOfField = parseHelpfulString "STRING" instance ParseField Any where - parseField = fmap (fmap Any) parseField + parseField h m = Any <$> parseField h m instance ParseField All where - parseField = fmap (fmap All) parseField + parseField h m = All <$> parseField h m -parseString :: String -> Maybe Text -> Parser String -parseString metavar m = +parseHelpfulString :: String -> Maybe Text -> Maybe Text -> Parser String +parseHelpfulString metavar h m = case m of Nothing -> do - let fs = Options.metavar metavar + let fs = Options.metavar metavar + <> maybe mempty (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 Options.option Options.str fs instance ParseField Data.Text.Text where - parseField = fmap (fmap Data.Text.pack) (parseString "TEXT") + parseField h m = Data.Text.pack <$> parseHelpfulString "TEXT" h m +instance ParseField Data.ByteString.ByteString where + parseField h m = fmap Data.Text.Encoding.encodeUtf8 (parseField h m) + instance ParseField Data.Text.Lazy.Text where - parseField = fmap (fmap Data.Text.Lazy.pack) (parseString "TEXT") + parseField h m = Data.Text.Lazy.pack <$> parseHelpfulString "TEXT" h m +instance ParseField Data.ByteString.Lazy.ByteString where + parseField h m = fmap Data.Text.Lazy.Encoding.encodeUtf8 (parseField h m) + instance ParseField FilePath where - parseField = fmap (fmap Filesystem.decodeString) (parseString "FILEPATH") + parseField h m = Filesystem.decodeString <$> parseHelpfulString "FILEPATH" h m instance ParseField Data.Time.Calendar.Day where - parseField m = do + 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 @@ -332,9 +411,11 @@ class ParseRecord a => ParseFields a where parseFields :: Maybe Text + -- ^ Help message + -> Maybe Text -- ^ Field label -> Parser a - default parseFields :: ParseField a => Maybe Text -> Parser a + default parseFields :: ParseField a => Maybe Text -> Maybe Text -> Parser a parseFields = parseField instance ParseFields Char @@ -344,47 +425,71 @@ instance ParseFields Integer instance ParseFields Ordering instance ParseFields Void +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 Bool where - parseFields m = + parseFields h m = case m of Nothing -> do let fs = Options.metavar "BOOL" + <> maybe mempty (Options.help . Data.Text.unpack) h Options.argument auto fs Just name -> do - Options.switch (Options.long (Data.Text.unpack name)) + Options.switch $ + Options.long (Data.Text.unpack name) + <> maybe mempty (Options.help . Data.Text.unpack) h instance ParseFields () where - parseFields _ = pure () + parseFields _ _ = pure () instance ParseFields Any where - parseFields = fmap (fmap mconcat . many . fmap Any) parseField + parseFields h m = (fmap mconcat . many . fmap Any) (parseField h m) instance ParseFields All where - parseFields = fmap (fmap mconcat . many . fmap All) parseField + parseFields h m = (fmap mconcat . many . fmap All) (parseField h m) instance ParseField a => ParseFields (Maybe a) where - parseFields = fmap optional parseField + parseFields h m = optional (parseField h m) instance ParseField a => ParseFields (First a) where - parseFields = fmap (fmap mconcat . many . fmap (First . Just)) parseField + parseFields h m = (fmap mconcat . many . fmap (First . Just)) (parseField h m) instance ParseField a => ParseFields (Last a) where - parseFields = fmap (fmap mconcat . many . fmap (Last . Just)) parseField + parseFields h m = (fmap mconcat . many . fmap (Last . Just)) (parseField h m) instance (Num a, ParseField a) => ParseFields (Sum a) where - parseFields = fmap (fmap mconcat . many . fmap Sum) parseField + parseFields h m = (fmap mconcat . many . fmap Sum) (parseField h m) instance (Num a, ParseField a) => ParseFields (Product a) where - parseFields = fmap (fmap mconcat . many . fmap Product) parseField + parseFields h m = (fmap mconcat . many . fmap Product) (parseField h m) instance ParseField a => ParseFields [a] where parseFields = parseListOfField +{-| Use this to annotate a field with a type-level string (i.e. a `Symbol`) + representing the help description for that field: + +> data Example = Example +> { foo :: Int "Documentation for the foo flag" +> , bar :: Double "Documentation for the bar flag" +> } deriving (Generic, Show) +-} +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 + +instance (ParseFields a, KnownSymbol h) => ParseFields (a h) where + parseFields _ m = Helpful <$> + parseFields ((Just . Data.Text.pack .symbolVal) (Proxy :: Proxy h)) m +instance (ParseFields a, KnownSymbol h) => ParseRecord (a h) + {-| A 1-tuple, used solely to translate `ParseFields` instances into `ParseRecord` instances -} @@ -452,6 +557,12 @@ 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 parseRecord = fmap getOnly parseRecord @@ -573,7 +684,7 @@ let label = case (selName m) of "" -> Nothing name -> Just (Data.Text.pack name) - fmap (M1 . K1) (parseFields label) + fmap (M1 . K1) (parseFields Nothing label) {- [NOTE - Sums]