optparse-generic (empty) → 1.0.0
raw patch · 4 files changed
+678/−0 lines, 4 filesdep +basedep +optparse-applicativedep +system-filepathsetup-changed
Dependencies added: base, optparse-applicative, system-filepath, text, transformers, void
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- optparse-generic.cabal +32/−0
- src/Options/Generic.hs +620/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2016 Gabriel Gonzalez+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * 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+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ optparse-generic.cabal view
@@ -0,0 +1,32 @@+Name: optparse-generic+Version: 1.0.0+Cabal-Version: >=1.8.0.2+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: 2016 Gabriel Gonzalez+Author: Gabriel Gonzalez+Maintainer: Gabriel439@gmail.com+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+ @Parser@ from any data type that derives the @Generic@ interface.+ .+ See the documentation in "Options.Generic" for an example of how to use+ this library+Category: System+Source-Repository head+ Type: git+ Location: https://github.com/Gabriel439/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.11.0 && < 0.13,+ void < 0.8+ Exposed-Modules: Options.Generic+ GHC-Options: -Wall
+ src/Options/Generic.hs view
@@ -0,0 +1,620 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This library auto-generates command-line parsers for data types using+-- Haskell's built-in support for generic programming. The best way to+-- understand how this library works is to walk through a few examples.+--+-- 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)+--+-- Named fields translate to flags which you can provide in any order:+--+-- > $ stack build optparse-generic+-- > $ stack runghc Example.hs -- --bar 2.5 --foo 1+-- > Example {foo = 1, bar = 2.5}+--+-- This also auto-generates @--help@ output:+--+-- > $ stack runghc Example.hs -- --help+-- > Test program+-- > +-- > Usage: Example.hs --foo INT --bar DOUBLE+-- > +-- > Available options:+-- > -h,--help Show this help text+--+-- For the following examples I encourage you to test what @--help@ output they+-- generate.+--+-- This library will also do the right thing if the fields have no labels:+--+-- > data Example = Example Int Double deriving (Generic, Show)+--+-- Fields without labels translate into positional command-line arguments:+--+-- > $ stack runghc Example.hs -- 1 2.5+-- > Example 1 2.5+--+-- Certain types of fields are given special treatment, such as in this+-- example:+--+-- > data Example = Example+-- > { switch :: Bool+-- > , list :: [Int]+-- > , optional :: Maybe Int+-- > , first :: First Int+-- > , last :: Last Int+-- > , sum :: Sum Int+-- > , product :: Product Int+-- > } deriving (Generic, Show)+--+-- 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 \+-- > --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 =+-- > 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+-- > = 0}, product = Product {getProduct = 1}}+--+-- If a datatype has multiple constructors:+--+-- > data Example+-- > = Create { name :: Text, duration :: Maybe Int }+-- > | Kill { name :: Text }+-- > deriving (Generic, Show)+--+-- ... then they will translate into subcommands named after each constructor:+--+-- > $ stack runghc Example.hs -- create --name foo --duration=60+-- > Create {name = "foo", duration = Just 60}+-- > $ stack runghc Example.hs -- kill --name foo+-- > Kill {name = "foo"}+--+-- 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)+--+-- > $ 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))+--+-- > $ 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)+--+-- > $ stack runghc Example.hs -- 2+-- > 2+--+-- However, there are some types that this library cannot generate sensible+-- command-line parsers for, such as:+--+-- * recursive types:+--+-- > data Example = Example { foo :: Example }+--+-- * records whose fields are other records+--+-- > data Outer = Outer { foo :: Inner } deriving (Show, Generic)+-- > data Inner = Inner { bar :: Int } deriving (Show, Generic)+--+-- * record fields with nested `Maybe`s or nested lists+--+-- > data Example = Example { foo :: Maybe (Maybe Int) }+-- > data Example = Example { foo :: [[Int]] }+--+-- If you try to auto-generate a parser for these types you will get an error at+-- compile time that will look something like this:+--+-- > No instance for (ParseFields TheTypeOfYourField)+-- > arising from a use of ‘Options.Generic.$gdmparseRecord’+-- > In the expression: Options.Generic.$gdmparseRecord+-- > In an equation for ‘parseRecord’:+-- > parseRecord = Options.Generic.$gdmparseRecord+-- > In the instance declaration for ‘ParseRecord TheTypeOfYourRecord’++module Options.Generic (+ -- * Parsers+ getRecord+ , ParseRecord(..)+ , ParseFields(..)+ , ParseField(..)+ , Only(..)+ , getOnly++ -- * Re-exports+ , Generic+ , Text+ , All(..)+ , Any(..)+ , First(..)+ , Last(..)+ , Sum(..)+ , Product(..)+ ) where++import Control.Applicative+import Control.Monad.IO.Class (MonadIO(..))+import Data.Char (toLower, toUpper)+import Data.Monoid+import Data.Text (Text)+import Data.Typeable (Typeable)+import Data.Void (Void)+import Filesystem.Path (FilePath)+import GHC.Generics+import Prelude hiding (FilePath)+import Options.Applicative (Parser, ReadM)++import qualified Data.Text+import qualified Data.Text.Lazy+import qualified Data.Typeable+import qualified Filesystem.Path.CurrentOS as Filesystem+import qualified Options.Applicative as Options+import qualified Options.Applicative.Types as Options+import qualified Text.Read++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++{-| A class for all record fields that can be parsed from exactly one option or+ argument on the command line++ `parseField` has a default implementation for any type that implements+ `Read` and `Typeable`. You can derive `Read` for many types and you can+ derive `Typeable` for any type if you enable the @DeriveDataTypeable@+ language extension+-}+class ParseField a where+ parseField+ :: Maybe Text+ -- ^ Field label+ -> Parser a+ default parseField :: (Typeable a, Read a) => Maybe Text -> Parser a+ parseField m = do+ let metavar = map toUpper (show (Data.Typeable.typeOf (undefined :: a)))+ case m of+ Nothing -> do+ let fs = Options.metavar metavar+ Options.argument auto fs+ Just name -> do+ let fs = Options.metavar metavar+ <> Options.long (Data.Text.unpack name)+ Options.option auto 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+ default implementation for `parseListOfField`+ -}+ parseListOfField+ :: Maybe Text+ -- ^ Field label+ -> Parser [a]+ parseListOfField = fmap many parseField++instance ParseField Bool+instance ParseField Double+instance ParseField Float+instance ParseField Int+instance ParseField Integer+instance ParseField Ordering+instance ParseField ()+instance ParseField Void++instance ParseField String where+ parseField = parseString "STRING"++instance ParseField Char where+ parseField 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+ Options.argument readM fs+ Just name -> do+ let fs = Options.metavar metavar+ <> Options.long (Data.Text.unpack name)+ Options.option readM fs++ parseListOfField = parseString "STRING"++instance ParseField Any where+ parseField = fmap (fmap Any) parseField+instance ParseField All where+ parseField = fmap (fmap All) parseField++parseString :: String -> Maybe Text -> Parser String+parseString metavar m =+ case m of+ Nothing -> do+ let fs = Options.metavar metavar+ Options.argument Options.str fs+ Just name -> do+ let fs = Options.metavar metavar+ <> Options.long (Data.Text.unpack name)+ Options.option Options.str fs++instance ParseField Data.Text.Text where+ parseField = fmap (fmap Data.Text.pack) (parseString "TEXT")++instance ParseField Data.Text.Lazy.Text where+ parseField = fmap (fmap Data.Text.Lazy.pack) (parseString "TEXT")++instance ParseField FilePath where+ parseField = fmap (fmap Filesystem.decodeString) (parseString "FILEPATH")++{-| A class for all types that can be parsed from zero or more arguments/options+ on the command line++ `parseFields` has a default implementation for any type that implements+ `ParseField`+-}+class ParseRecord a => ParseFields a where+ parseFields+ :: Maybe Text+ -- ^ Field label+ -> Parser a+ default parseFields :: ParseField a => Maybe Text -> Parser a+ parseFields = parseField++instance ParseFields Char+instance ParseFields Double+instance ParseFields Float+instance ParseFields Int+instance ParseFields Integer+instance ParseFields Ordering+instance ParseFields Void+instance ParseFields Data.Text.Text+instance ParseFields Data.Text.Lazy.Text+instance ParseFields FilePath++instance ParseFields Bool where+ parseFields m =+ case m of+ Nothing -> do+ let fs = Options.metavar "BOOL"+ Options.argument auto fs+ Just name -> do+ Options.switch (Options.long (Data.Text.unpack name))++instance ParseFields () where+ parseFields _ = pure ()++instance ParseFields Any where+ parseFields = fmap (fmap mconcat . many . fmap Any) parseField++instance ParseFields All where+ parseFields = fmap (fmap mconcat . many . fmap All) parseField++instance ParseField a => ParseFields (Maybe a) where+ parseFields = fmap optional parseField++instance ParseField a => ParseFields (First a) where+ parseFields = fmap (fmap mconcat . many . fmap (First . Just)) parseField++instance ParseField a => ParseFields (Last a) where+ parseFields = fmap (fmap mconcat . many . fmap (Last . Just)) parseField++instance (Num a, ParseField a) => ParseFields (Sum a) where+ parseFields = fmap (fmap mconcat . many . fmap Sum) parseField++instance (Num a, ParseField a) => ParseFields (Product a) where+ parseFields = fmap (fmap mconcat . many . fmap Product) parseField++instance ParseField a => ParseFields [a] where+ parseFields = parseListOfField++{-| A 1-tuple, used solely to translate `ParseFields` instances into+ `ParseRecord` instances+-}+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+ the same type:++> instance ParseRecord MyType where+> parseRecord = fmap getOnly parseRecord+-}+getOnly :: Only a -> a+getOnly (Only x) = x++{-| A class for types that can be parsed from the command line++ This class has a default implementation for any type that implements+ `Generic` and you can derive `Generic` for many types by enabling the+ @DeriveGeneric@ language extension++ You can also use `getOnly` to create a `ParseRecord` instance from a+ `ParseFields` instance:++> instance ParseRecord MyType where+> parseRecord = fmap getOnly parseRecord+-}+class ParseRecord a where+ parseRecord :: Parser a+ default parseRecord :: (Generic a, GenericParseRecord (Rep a)) => Parser a+ parseRecord = fmap GHC.Generics.to genericParseRecord++instance ParseFields a => ParseRecord (Only a)++instance ParseRecord Char+instance ParseRecord Double+instance ParseRecord Float+instance ParseRecord Int+instance ParseRecord Ordering+instance ParseRecord Void+instance ParseRecord ()++instance ParseRecord Bool where+ parseRecord = fmap getOnly parseRecord++instance ParseRecord Integer where+ parseRecord = fmap getOnly parseRecord++instance ParseRecord Data.Text.Text where+ parseRecord = fmap getOnly parseRecord++instance ParseRecord Data.Text.Lazy.Text where+ parseRecord = fmap getOnly parseRecord++instance ParseRecord Any where+ parseRecord = fmap getOnly parseRecord++instance ParseRecord All where+ parseRecord = fmap getOnly parseRecord++instance ParseRecord FilePath where+ parseRecord = fmap getOnly parseRecord++instance ParseField a => ParseRecord (Maybe a) where+ parseRecord = fmap getOnly parseRecord++instance ParseField a => ParseRecord (First a) where+ parseRecord = fmap getOnly parseRecord++instance ParseField a => ParseRecord (Last a) where+ parseRecord = fmap getOnly parseRecord++instance (Num a, ParseField a) => ParseRecord (Sum a) where+ parseRecord = fmap getOnly parseRecord++instance (Num a, ParseField a) => ParseRecord (Product a) where+ parseRecord = fmap getOnly parseRecord++instance ParseField a => ParseRecord [a] where+ parseRecord = fmap getOnly parseRecord++instance (ParseFields a, ParseFields b) => ParseRecord (a, b)+instance (ParseFields a, ParseFields b, ParseFields c) => ParseRecord (a, b, c)+instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d) => ParseRecord (a, b, c, d)+instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d, ParseFields e) => ParseRecord (a, b, c, d, e)+instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d, ParseFields e, ParseFields f) => ParseRecord (a, b, c, d, e, f)+instance (ParseFields a, ParseFields b, ParseFields c, ParseFields d, ParseFields e, ParseFields f, ParseFields g) => ParseRecord (a, b, c, d, e, f, g)++instance (ParseFields a, ParseFields b) => ParseRecord (Either a b)++class GenericParseRecord f where+ genericParseRecord :: Parser (f p)++instance GenericParseRecord U1 where+ genericParseRecord = pure U1++-- See: [NOTE - Sums]+instance GenericParseRecord f => GenericParseRecord (M1 C c f) where+ genericParseRecord = fmap M1 genericParseRecord++-- See: [NOTE - Sums]+instance (Constructor c, GenericParseRecord f, GenericParseRecord (g :+: h)) => GenericParseRecord (M1 C c f :+: (g :+: h)) where+ genericParseRecord = do+ let m :: M1 i c f a+ m = undefined++ let name = map toLower (conName m)++ let info = Options.info (Options.helper <*> genericParseRecord) mempty++ let subparserFields =+ Options.command name info+ <> Options.metavar name++ let parser = Options.subparser subparserFields++ fmap (L1 . M1) parser <|> genericParseRecord++-- See: [NOTE - Sums]+instance (Constructor c, GenericParseRecord (f :+: g), GenericParseRecord h) => GenericParseRecord ((f :+: g) :+: M1 C c h) where+ genericParseRecord = do+ let m :: M1 i c h a+ m = undefined++ let name = map toLower (conName m)++ let info = Options.info (Options.helper <*> genericParseRecord) mempty++ let subparserFields =+ Options.command name info+ <> Options.metavar name++ let parser = Options.subparser subparserFields++ genericParseRecord <|> 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+ 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 info1 = Options.info (Options.helper <*> genericParseRecord) mempty+ let info2 = Options.info (Options.helper <*> genericParseRecord) mempty++ let subparserFields1 =+ Options.command name1 info1+ <> Options.metavar name1+ let subparserFields2 =+ Options.command name2 info2+ <> Options.metavar name2++ let parser1 = Options.subparser subparserFields1+ let parser2 = Options.subparser subparserFields2++ fmap (L1 . M1) parser1 <|> fmap (R1 . M1) parser2++instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :*: g) where+ genericParseRecord = liftA2 (:*:) genericParseRecord genericParseRecord++instance GenericParseRecord V1 where+ genericParseRecord = empty++instance (Selector s, ParseFields a) => GenericParseRecord (M1 S s (K1 i a)) where+ genericParseRecord = do+ let m :: M1 i s f a+ m = undefined++ let label = case (selName m) of+ "" -> Nothing+ name -> Just (Data.Text.pack name)+ fmap (M1 . K1) (parseFields label)++{- [NOTE - Sums]++ You might wonder why the `GenericParseRecord` instances for `(:+:)` are so+ complicated. A much simpler approach would be something like this:++> instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :+: g) where+> genericParseRecord = fmap L1 genericParseRecord <|> fmap R1 genericParseRecord+> +> instance (Constructor c, GenericParseRecord f) => GenericParseRecord (M1 C c f) where+> genericParseRecord = do+> let m :: M1 i c f a+> m = undefined+> +> let name = map toLower (conName m)+> +> let info = Options.info genericParseRecord mempty+> +> let subparserFields =+> Options.command n info+> <> Options.metavar n+> +> fmap M1 (Options.subparser subparserFields)++ The reason for the extra complication is so that datatypes with just one+ constructor don't have subcommands. That way, if a user defines a data+ type like:++> data Example = Example { foo :: Double } deriving (Generic)+>+> instance ParseRecord Example++ .. then the command line will only read in the @--foo@ flag and won't+ expect a gratuitous @example@ subcommand:++> ./example --foo 2++ However, if a user defines a data type with two constructors then the+ subcommand support will kick in.++ Some other alternatives that I considered and rejected:++ * Alternative #1: Constructors prefixed with something like @Command_@ are+ turned into sub-commands named after the constructor with the prefix+ stripped. If the prefix is not present then they don't get a subcommand.++ I rejected this approach for several reasons:++ * It's ugly+ * It's error-prone (consider the case: @data T = C1 Int | C2 Int@, which+ would never successfully parse @C2@). Subcommands should be mandatory+ for types with multiple constructors+ * It doesn't work "out-of-the-box" for most types in the Haskell+ ecosystem which were not written with this library in mind++ * Alternative #2: Any constructor named some reserved name (like @Only@)+ would not generate a sub-command.++ I rejected this approach for a couple of reasons:++ * Too surprising. The user would never know or guess about this+ behavior without reading the documentation.+ * Doesn't work "out-of-the-box" for single-constructor types in the+ Haskell ecosystem (like `(a, b)`, for example)+-}++instance GenericParseRecord f => GenericParseRecord (M1 D c f) where+ genericParseRecord = fmap M1 (Options.helper <*> genericParseRecord)++-- | Marshal any value that implements `ParseRecord` from the command line+getRecord+ :: (MonadIO io, ParseRecord a)+ => Text+ -- ^ Program description+ -> io a+getRecord desc = liftIO (Options.execParser info)+ where+ header = Options.header (Data.Text.unpack desc)++ info = Options.info parseRecord header