module Options.Generic (
getRecord
, ParseRecord(..)
, ParseFields(..)
, ParseField(..)
, Only(..)
, getOnly
, 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
class ParseField a where
parseField
:: Maybe Text
-> 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
parseListOfField
:: Maybe Text
-> 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")
class ParseRecord a => ParseFields a where
parseFields
:: Maybe Text
-> 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
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
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
instance GenericParseRecord f => GenericParseRecord (M1 C c f) where
genericParseRecord = fmap M1 genericParseRecord
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
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
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)
instance GenericParseRecord f => GenericParseRecord (M1 D c f) where
genericParseRecord = fmap M1 (Options.helper <*> genericParseRecord)
getRecord
:: (MonadIO io, ParseRecord a)
=> Text
-> io a
getRecord desc = liftIO (Options.execParser info)
where
header = Options.header (Data.Text.unpack desc)
info = Options.info parseRecord header