optparse-generic 1.0.1 → 1.1.0
raw patch · 2 files changed
+154/−38 lines, 2 filesdep +bytestringdep +singletonsdep +tagged
Dependencies added: bytestring, singletons, tagged
Files
- optparse-generic.cabal +8/−3
- src/Options/Generic.hs +146/−35
optparse-generic.cabal view
@@ -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
src/Options/Generic.hs view
@@ -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]