{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-partial-fields -fno-warn-orphans #-}
module Main where
import Data.Char qualified as Char
import Data.List (dropWhileEnd)
import Data.Text qualified as T
import GHC.Generics
import Options.Applicative qualified as Options
import Options.Generic
import Options.TH
import Test.Hspec
import Prelude
newtype ViaGeneric a = ViaGeneric a
deriving stock (Show, Eq)
instance (GenericParseRecord (Rep a), Generic a) => ParseRecord (ViaGeneric a) where
parseRecord = fmap (ViaGeneric . to) (genericParseRecord defaultModifiers)
data UnitCmd = UnitCmd
deriving stock (Show, Eq, Generic)
data PositionalCmd = PositionalCmd Int Char
deriving stock (Show, Eq, Generic)
data RecordCmd = RecordCmd {recordFst :: Int, recordSnd :: Char}
deriving stock (Show, Eq, Generic)
data SubCommands
= Foo Int Char
| Bar {barInt :: Int, barChar :: Char}
deriving stock (Show, Eq, Generic)
data WrappedSubCommands w
= FooW (w ::: Int <?> "help for int") (w ::: Char <?> "help for char")
| BarW
{ barWInt :: w ::: Int <?> "help for int"
, barWChar :: w ::: Char <?> "help for char"
}
deriving stock (Generic)
#if MIN_VERSION_optparse_generic(1,5,1)
#else
deriving stock instance (Eq a) => Eq (a <#> msg)
deriving stock instance (Eq a) => Eq (a <?> msg)
deriving stock instance (Eq a) => Eq (a <!> msg)
#endif
deriving stock instance Show (WrappedSubCommands Wrapped)
deriving stock instance Eq (WrappedSubCommands Wrapped)
data WrappedTest w
= SomehowUnwrapped Int Char
| WrappedNoMod (w ::: Int)
| WrappedHelpful (w ::: Int <?> "wow helpful")
| WrappedDef (w ::: Int <!> "1")
| WrappedHelpfulAndDef (w ::: Int <!> "1" <?> "wow helpful")
| WrappedDefAndHelpful (w ::: Int <?> "wow helpful" <!> "1")
| WrappedAllTheThings {wrappedLabel :: w ::: Int <!> "1" <?> "wow help" <#> "i"}
deriving stock (Generic)
deriving stock instance Show (WrappedTest Wrapped)
deriving stock instance Eq (WrappedTest Wrapped)
deriving stock instance Show (WrappedTest Unwrapped)
deriving stock instance Eq (WrappedTest Unwrapped)
fmap concat $
traverse
(deriveParseRecord defaultModifiers)
[ ''UnitCmd
, ''PositionalCmd
, ''RecordCmd
, ''SubCommands
, ''WrappedSubCommands
, ''WrappedTest
]
-- this function is mostly copied from optparse-generic, but exposing the
-- failure as a string
pureParseRecord :: ParseRecord a => [Text] -> IO (Either [String] a)
pureParseRecord args = pure do
let infoMod = mempty
prefsMod = mempty
let header = Options.header ""
let info = Options.info parseRecord (header <> infoMod)
let prefs = Options.prefs (defaultParserPrefs <> prefsMod)
let args' = map T.unpack args
case Options.execParserPure prefs info args' of
Options.Success a -> Right a
Options.Failure f ->
Left $ map (dropWhileEnd Char.isSpace) $ lines $ fst $ Options.renderFailure f "test"
Options.CompletionInvoked _ -> Left $ pure "completion invoked???"
where
defaultParserPrefs =
Options.multiSuffix "..."
spec :: Spec
spec = do
let subjectGeneric ::
forall a.
(Show a, Eq a, ParseRecord a, Generic a, GenericParseRecord (Rep a)) =>
[Text] ->
(Either [String] a -> IO ()) ->
IO ()
subjectGeneric args k = do
viaTH <- pureParseRecord args
viaGeneric <- fmap (\(ViaGeneric a) -> a) <$> pureParseRecord args
viaTH `shouldBe` viaGeneric
k viaTH
describe "UnitCmd" do
let subject = subjectGeneric @UnitCmd
it "works with empty args" do
subject [] \th ->
th `shouldBe` Right UnitCmd
it "fails with other args" do
subject ["asdf"] \th ->
th
`shouldBe` Left
[ "Invalid argument `asdf'"
, ""
, "Usage: test"
]
describe "PositionalCmd" do
let subject = subjectGeneric @PositionalCmd
it "works with proper args" do
subject ["3", "a"] \th ->
th `shouldBe` do
Right $ PositionalCmd 3 'a'
it "fails with wrong args" do
subject [] \th ->
th
`shouldBe` Left
[ "Missing: INT CHAR"
, ""
, "Usage: test INT CHAR"
]
describe "RecordCmd" do
let subject = subjectGeneric @RecordCmd
it "works with proper args" do
subject ["--recordFst", "3", "--recordSnd", "a"] \th ->
th `shouldBe` do
Right $ RecordCmd 3 'a'
it "works with proper args in reverse order" do
subject ["--recordSnd", "a", "--recordFst", "3"] \th ->
th `shouldBe` do
Right $ RecordCmd 3 'a'
it "fails with wrong args" do
subject ["3", "a"] \th ->
th
`shouldBe` Left
[ "Invalid argument `3'"
, ""
, "Did you mean this?"
, " -h"
, ""
, "Usage: test --recordFst INT --recordSnd CHAR"
]
describe "SubCommands" do
let subject = subjectGeneric @SubCommands
describe "Foo" do
it "works as positional subcommand" do
subject ["foo", "3", "a"] \th ->
th `shouldBe` do
Right $ Foo 3 'a'
describe "Bar" do
it "works as record subcommand" do
subject ["bar", "--barInt", "3", "--barChar", "a"] \th ->
th `shouldBe` do
Right $ Bar 3 'a'
describe "WrappedSubCommands" do
let subject = subjectGeneric @(WrappedSubCommands Wrapped)
it "has useful --help" do
subject ["--help"] \th -> do
th
`shouldBe` Left
[ "Usage: test (foow | barw)"
, ""
, "Available options:"
, " -h,--help Show this help text"
, ""
, "Available commands:"
, " foow"
, " barw"
]
describe "FooW" do
it "works as positional subcommand" do
subject ["foow", "3", "a"] \th -> do
th `shouldBe` do
Right $ FooW (Helpful 3) (Helpful 'a')
it "help is useful" do
subject ["foow", "--help"] \th -> do
th
`shouldBe` Left
[ "Usage: test foow INT CHAR"
, ""
, "Available options:"
, " -h,--help Show this help text"
, " INT help for int"
, " CHAR help for char"
]
describe "WrappedTest" do
let subject = subjectGeneric @(WrappedTest Wrapped)
it "help is useful" do
subject ["--help"] \t ->
t
`shouldBe` Left
[ "Usage: test (somehowunwrapped | wrappednomod | wrappedhelpful | wrappeddef |"
, " wrappedhelpfulanddef | wrappeddefandhelpful | wrappedallthethings)"
, ""
, "Available options:"
, " -h,--help Show this help text"
, ""
, "Available commands:"
, " somehowunwrapped"
, " wrappednomod"
, " wrappedhelpful"
, " wrappeddef"
, " wrappedhelpfulanddef"
, " wrappeddefandhelpful"
, " wrappedallthethings"
]
describe "SomehowUnwrapped" do
it "works as usual" do
subject ["somehowunwrapped", "3", "a"] \t ->
t `shouldBe` Right do
SomehowUnwrapped 3 'a'
describe "WrappedNoMod" do
it "works as usual" do
subject ["wrappednomod", "3"] \t ->
t `shouldBe` Right do
WrappedNoMod 3
describe "WrappedHelpful" do
it "parses correctly" do
subject ["wrappedhelpful", "3"] \t ->
t `shouldBe` Right do
WrappedHelpful (Helpful 3)
it "can be unwrapped" do
subject ["wrappedhelpful", "3"] \t -> do
fmap unwrapRecordWrappedTest t `shouldBe` Right do
WrappedHelpful 3
fmap unwrap t `shouldBe` Right do
WrappedHelpful 3
it "has useful help" do
subject ["wrappedhelpful", "--help"] \t ->
t
`shouldBe` Left
[ "Usage: test wrappedhelpful INT"
, ""
, "Available options:"
, " -h,--help Show this help text"
, " INT wow helpful"
]
describe "WrappedAllTheThings" do
it "parses with long name" do
subject ["wrappedallthethings", "--wrappedLabel", "1"] \t ->
fmap unwrapRecordWrappedTest t `shouldBe` Right do
WrappedAllTheThings 1
it "parses with short name" do
subject ["wrappedallthethings", "-i", "1"] \t ->
fmap unwrapRecordWrappedTest t `shouldBe` Right do
WrappedAllTheThings 1
it "parses without option as default" do
subject ["wrappedallthethings"] \t ->
fmap unwrapRecordWrappedTest t `shouldBe` Right do
WrappedAllTheThings 1
it "has useful help" do
subject ["wrappedallthethings", "--help"] \t ->
fmap unwrapRecordWrappedTest t
`shouldBe` Left
[ "Usage: test wrappedallthethings [-i|--wrappedLabel INT]"
, ""
, "Available options:"
, " -h,--help Show this help text"
, " -i,--wrappedLabel INT wow help (default: 1)"
]
main :: IO ()
main = hspec spec