module Options.Generic (
getRecord
, getRecordPure
, ParseRecord(..)
, ParseFields(..)
, ParseField(..)
, Only(..)
, getOnly
, Modifiers(..)
, parseRecordWithModifiers
, defaultModifiers
, type (<?>)(..)
, 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.List.NonEmpty (NonEmpty((:|)))
import Data.Proxy
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.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
case Text.Read.readMaybe s of
Just x -> return x
Nothing -> Options.readerAbort Options.ShowHelpText
class ParseField a where
parseField
:: Maybe Text
-> Maybe Text
-> Parser a
default parseField
:: (Typeable a, Read a)
=> Maybe Text
-> Maybe Text
-> 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
parseListOfField
:: Maybe Text
-> Maybe Text
-> Parser [a]
parseListOfField h m = many (parseField h m)
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 = 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
parseListOfField = parseHelpfulString "STRING"
instance ParseField Any where
parseField h m = Any <$> parseField h m
instance ParseField All where
parseField h m = All <$> parseField h m
parseHelpfulString :: String -> Maybe Text -> Maybe Text -> Parser String
parseHelpfulString metavar h m =
case m of
Nothing -> do
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 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 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 h m = Filesystem.decodeString <$> parseHelpfulString "FILEPATH" h m
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"
runReadS [(day, "")] = Right day
runReadS _ = Left "expected YYYY-MM-DD"
class ParseRecord a => ParseFields a where
parseFields
:: Maybe Text
-> Maybe Text
-> Parser a
default parseFields :: ParseField a => Maybe Text -> 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.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 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)
<> maybe mempty (Options.help . Data.Text.unpack) h
instance ParseFields () where
parseFields _ _ = pure ()
instance ParseFields Any where
parseFields h m = (fmap mconcat . many . fmap Any) (parseField h m)
instance ParseFields All where
parseFields h m = (fmap mconcat . many . fmap All) (parseField h m)
instance ParseField a => ParseFields (Maybe a) where
parseFields h m = optional (parseField h m)
instance ParseField a => ParseFields (First a) where
parseFields h m = (fmap mconcat . many . fmap (First . Just)) (parseField h m)
instance ParseField a => ParseFields (Last a) where
parseFields h m = (fmap mconcat . many . fmap (Last . Just)) (parseField h m)
instance (Num a, ParseField a) => ParseFields (Sum a) where
parseFields h m = (fmap mconcat . many . fmap Sum) (parseField h m)
instance (Num a, ParseField a) => ParseFields (Product a) where
parseFields h m = (fmap mconcat . many . fmap Product) (parseField h m)
instance ParseField a => ParseFields [a] where
parseFields = parseListOfField
instance ParseField a => ParseFields (NonEmpty a) where
parseFields h m = (:|) <$> parseField h m <*> parseListOfField h m
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)
newtype Only a = Only a deriving (Generic, Show)
getOnly :: Only a -> a
getOnly (Only x) = x
class ParseRecord a where
parseRecord :: Parser a
default parseRecord :: (Generic a, GenericParseRecord (Rep a)) => Parser a
parseRecord = fmap GHC.Generics.to (genericParseRecord defaultModifiers)
instance ParseFields a => ParseRecord (Only a)
instance ParseRecord Char where
parseRecord = fmap getOnly parseRecord
instance ParseRecord Double where
parseRecord = fmap getOnly parseRecord
instance ParseRecord Float where
parseRecord = fmap getOnly parseRecord
instance ParseRecord Int where
parseRecord = fmap getOnly parseRecord
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 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
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 ParseField a => ParseRecord (NonEmpty 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)
data Modifiers = Modifiers
{ fieldNameModifier :: String -> String
, constructorNameModifier :: String -> String
}
defaultModifiers :: Modifiers
defaultModifiers = Modifiers id (map toLower)
class GenericParseRecord f where
genericParseRecord :: Modifiers -> Parser (f p)
instance GenericParseRecord U1 where
genericParseRecord _ = pure U1
instance GenericParseRecord f => GenericParseRecord (M1 C c f) where
genericParseRecord = fmap M1 . genericParseRecord
instance (GenericParseRecord (f :+: g), GenericParseRecord (h :+: i)) => GenericParseRecord ((f :+: g) :+: (h :+: i)) where
genericParseRecord mods = do
fmap L1 (genericParseRecord mods) <|> fmap R1 (genericParseRecord mods)
instance (Constructor c, GenericParseRecord f, GenericParseRecord (g :+: h)) => GenericParseRecord (M1 C c f :+: (g :+: h)) where
genericParseRecord mods@Modifiers{..} = do
let m :: M1 i c f a
m = undefined
let name = constructorNameModifier (conName m)
let info = Options.info (Options.helper <*> (genericParseRecord mods)) mempty
let subparserFields =
Options.command name info
<> Options.metavar name
let parser = Options.subparser subparserFields
fmap (L1 . M1) parser <|> fmap R1 (genericParseRecord mods)
instance (Constructor c, GenericParseRecord (f :+: g), GenericParseRecord h) => GenericParseRecord ((f :+: g) :+: M1 C c h) where
genericParseRecord mods@Modifiers{..} = do
let m :: M1 i c h a
m = undefined
let name = constructorNameModifier (conName m)
let info = Options.info (Options.helper <*> (genericParseRecord mods)) mempty
let subparserFields =
Options.command name info
<> Options.metavar name
let parser = Options.subparser subparserFields
fmap L1 (genericParseRecord mods) <|> fmap (R1 . M1) parser
instance (Constructor c1, Constructor c2, GenericParseRecord f1, GenericParseRecord f2) => GenericParseRecord (M1 C c1 f1 :+: M1 C c2 f2) where
genericParseRecord mods@Modifiers{..} = do
let m1 :: M1 i c1 f a
m1 = undefined
let m2 :: M1 i c2 g a
m2 = undefined
let name1 = constructorNameModifier (conName m1)
let name2 = constructorNameModifier (conName m2)
let info1 = Options.info (Options.helper <*> (genericParseRecord mods)) mempty
let info2 = Options.info (Options.helper <*> (genericParseRecord mods)) 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 mods = liftA2 (:*:) (genericParseRecord mods) (genericParseRecord mods)
instance GenericParseRecord V1 where
genericParseRecord _ = empty
instance (Selector s, ParseFields a) => GenericParseRecord (M1 S s (K1 i a)) where
genericParseRecord Modifiers{..} = do
let m :: M1 i s f a
m = undefined
let label = case (selName m) of
"" -> Nothing
name -> Just (Data.Text.pack (fieldNameModifier name))
fmap (M1 . K1) (parseFields Nothing label)
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
parseRecordWithModifiers mods = fmap GHC.Generics.to (genericParseRecord mods)
getRecord
:: (MonadIO io, ParseRecord a)
=> Text
-> io a
getRecord desc = liftIO (Options.customExecParser prefs info)
where
prefs = Options.defaultPrefs
{ Options.prefMultiSuffix = "..."
}
header = Options.header (Data.Text.unpack desc)
info = Options.info parseRecord header
getRecordPure
:: ParseRecord a
=> [Text]
-> Maybe a
getRecordPure args = do
let prefs = Options.ParserPrefs
{ prefMultiSuffix = "..."
, prefDisambiguate = False
, prefShowHelpOnError = False
, prefBacktrack = True
, prefColumns = 80
#if MIN_VERSION_optparse_applicative(0,13,0)
, prefShowHelpOnEmpty = False
#else
#endif
}
let header = Options.header ""
let info = Options.info parseRecord header
let args' = map Data.Text.unpack args
Options.getParseResult (Options.execParserPure prefs info args')