diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `optparse-th` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2023-12-07 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# `optparse-th` + +This package is designed to provide a `TemplateHaskell` variant of `optparse-generic`. +The `Generic` instance for very large sum types becomes an extremely onerous thing to compile. +`TemplateHaskell` is able to generate the required code very quickly, which is much more efficient than going through a `Generic` pass that must be re-derived every time the module recompiles. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/optparse-th.cabal b/optparse-th.cabal new file mode 100644 --- /dev/null +++ b/optparse-th.cabal @@ -0,0 +1,134 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.4. +-- +-- see: https://github.com/sol/hpack + +name: optparse-th +version: 0.1.0.0 +synopsis: Like `optparse-generic`, but with `TemplateHaskell` for faster builds +description: Please see the README on GitHub at +category: System +homepage: https://github.com/MercuryTechnologies/optparse-th#readme +bug-reports: https://github.com/MercuryTechnologies/optparse-th/issues +author: Matt von Hagen +maintainer: mattp@mercury.com +copyright: 2023 Mercury Technologies +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/MercuryTechnologies/optparse-th + +library + exposed-modules: + Options.TH + other-modules: + Paths_optparse_th + autogen-modules: + Paths_optparse_th + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NegativeLiterals + NumericUnderscores + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + UndecidableInstances + ViewPatterns + TypeOperators + NoForeignFunctionInterface + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.14 && <5 + , optparse-applicative + , optparse-generic + , template-haskell + , text + default-language: Haskell2010 + +test-suite optparse-th-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_optparse_th + autogen-modules: + Paths_optparse_th + hs-source-dirs: + test + default-extensions: + BlockArguments + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NegativeLiterals + NumericUnderscores + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + UndecidableInstances + ViewPatterns + TypeOperators + NoForeignFunctionInterface + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.14 && <5 + , hspec + , optparse-applicative + , optparse-generic + , optparse-th + , template-haskell + , text + default-language: Haskell2010 diff --git a/src/Options/TH.hs b/src/Options/TH.hs new file mode 100644 --- /dev/null +++ b/src/Options/TH.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +-- | This module is designed to provide a @TemplateHaskell@ alternative to +-- "Options.Generic". +module Options.TH + ( deriveParseRecord, + module Options.Generic, + ) +where + +import Data.Foldable (asum) +import Control.Applicative +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as T +import Data.Traversable +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Options.Applicative qualified as Options +import Options.Generic + +-- | This function derives 'ParseRecord' for you without incurring a 'Generic' +-- dependency. +-- +-- The main barrier here to fully supporting the library is that the API for +-- 'ParseRecord' does not expose the function that provides modifiers by +-- default. So we can provide an instance of 'ParseRecord', but we can't provide +-- a replacement of 'parseRecordWithModifiers', because that function is defined +-- as a top-level that delegates directly to the generic. +-- +-- @ +-- parseRecordWithModifiers +-- :: (Generic a, GenericParseRecord (Rep a)) +-- => Modifiers +-- -> Parser +-- parseRecordWithModifiers modifiers = +-- fmap GHC.Generics.to (genericParseRecord modifiers) +-- @ +-- +-- This means that we need to shift the options to the compile-time site, +-- instead of the runtime site. +-- +-- Likewise, we cannot provide an instance of 'Unwrappable', because it's not +-- a class - it's a type alias for 'Generic' stuff. So we need to create +-- a separate top-level function that does the unwrap. +-- +-- @since 0.1.0.0 +deriveParseRecord :: Modifiers -> Name -> Q [Dec] +deriveParseRecord modifiers tyName = do + tyInfo <- reify tyName + + datatype <- + getDatatypeForInfo tyName tyInfo + + + liftA2 (<>) (datatypeToInstanceDec modifiers datatype) (datatypeToUnwrapRecordDec tyName datatype) + +datatypeToUnwrapRecordDec :: Name -> Datatype -> Q [Dec] +datatypeToUnwrapRecordDec typeName datatype = do + if datatypeIsWrapped datatype + then do + let fnName = + mkName ("unwrapRecord" <> nameBase typeName) + fnType = + [t|$(conT typeName) Wrapped -> $(conT typeName) Unwrapped|] + fnExpr = mkUnwrapRecordExpr datatype + fnSig = SigD fnName <$> fnType + (:) + <$> fnSig + <*> [d| + $(varP fnName) = $(fnExpr) + |] + else do + pure [] + +mkUnwrapRecordExpr :: Datatype -> Q Exp +mkUnwrapRecordExpr datatype = do + let mkMatch con = + case con of + NormalC name bangTyps -> do + (pat, namesAndTypes) <- do + namesAndTypes <- + for bangTyps \(_bang, typ) -> do + n <- newName "x" + pure (n, typ) + + pure + ( mkConP name (map (\(varName, _fieldType) -> VarP varName) namesAndTypes) + , namesAndTypes + ) + body <- do + let constr = ConE name + fields <- traverse unwrapFields namesAndTypes + pure $ NormalB $ foldl' AppE constr fields + let decs = + [] + pure $ + Match pat body decs + RecC name varBangTypes -> do + (pat, varNames) <- do + varNames <- + for varBangTypes \(_fieldName, _bang, typ) -> do + n <- newName "x" + pure (n, typ) + + pure + ( mkConP name (map (\(varName, _fieldType) -> VarP varName) varNames) + , varNames + ) + body <- do + let constr = ConE name + fields <- traverse unwrapFields varNames + pure $ NormalB $ foldl' AppE constr fields + let decs = + [] + pure $ + Match pat body decs + _ -> + fail $ + unlines + [ "Unexpected constructor in mkUnwrapRecordExpr: " + , " " <> show con + ] + + matches <- + traverse mkMatch (datatypeConstructors datatype) + + pure $ LamCaseE (NonEmpty.toList matches) + +-- | Test the type of the field. If it is unwrappable, unwrap it until it isn't. +unwrapFields :: (Name, Type) -> Q Exp +unwrapFields (varName, varTyp) = + case varTyp of + AppT + ( AppT + (ConT ((== ''(Options.Generic.:::)) -> True)) + (VarT _) + ) + rest -> do + tryUnwrapping varName rest + _ -> + varE varName + +-- | The goal of this function is to test to see if the constructor is +-- unwrappable: that is, one of , , or <#>. +-- +-- If it is unwrappable, then we call the relevant function. Note that we have +-- to try multiple times, since you can put a wrapper in any order. +tryUnwrapping :: Name -> Type -> Q Exp +tryUnwrapping varName = go [] + where + go fns varTyp = do + case varTyp of + ( AppT + (ConT ((== ''(Options.Generic.)) -> True)) + rest + ) + `AppT` _helpText -> + do + go (VarE 'unHelpful : fns) rest + AppT + ( AppT + (ConT ((== ''(Options.Generic.)) -> True)) + rest + ) + _defVal -> + do + go (VarE 'unDefValue : fns) rest + AppT + ( AppT + (ConT ((== ''(Options.Generic.<#>)) -> True)) + rest + ) + _shortLabel -> + go (VarE 'unShortName : fns) rest + _ -> do + foldr (\fn acc -> pure fn `appE` acc) (varE varName) fns + +getDatatypeForInfo :: Name -> Info -> Q Datatype +getDatatypeForInfo tyName tyInfo = + case tyInfo of + TyConI dec -> + case dec of + DataD _xct name bndrs _mkind constructors _derivs -> do + case constructors of + [] -> + fail $ + unlines + [ "A `ParseRecord` instance can't be generated for the following type:" + , " " <> show tyName + , "... because it has no constructors." + ] + (c : cs) -> do + pure + Datatype + { datatypeName = + name + , datatypeConstructors = + c :| cs + , datatypeIsWrapped = + not (null bndrs) + } + NewtypeD _cxt name bndrs _mkind constructor _derivs -> do + pure + Datatype + { datatypeName = + name + , datatypeConstructors = + pure constructor + , datatypeIsWrapped = + not (null bndrs) + } + _ -> + fail $ + unlines + [ "Internal error: Options.TH.getDatatypeForInfo." + , "" + , "This is not your fault. Open a bug report and include the following error for the context in the report: " <> show dec + , "The GHC API provided a `TyConI` wrapping a declaration that was not a `data` or `newtype` declaration, which should never happen." + ] + _ -> do + fail $ + mconcat + [ "Expected a type constructor in 'deriveParseRecord', got: " + , "\n\t" + , show tyInfo + ] + +data Datatype = Datatype + { datatypeName :: Name + , datatypeIsWrapped :: Bool + , datatypeConstructors :: NonEmpty Con + } + +datatypeToInstanceDec :: Modifiers -> Datatype -> Q [Dec] +datatypeToInstanceDec mods Datatype {..} = do + let saturatedType = + if datatypeIsWrapped + then ConT datatypeName `AppT` ConT ''Wrapped + else ConT datatypeName + + parseRecordExpr <- + case datatypeConstructors of + singleConstructor :| [] -> do + makeSingleCommand mods singleConstructor + subcommands -> do + [|asum|] `appE` listE (NonEmpty.toList (fmap (makeSubcommand mods) subcommands)) + + [d| + instance ParseRecord $(pure saturatedType) where + parseRecord = + Options.helper <*> $(pure parseRecordExpr) + |] + +-- | This function should be called on a single constructor. No subcommand +-- should be created. +makeSingleCommand :: Modifiers -> Con -> Q Exp +makeSingleCommand Modifiers {..} con = do + case con of + NormalC conName bangTypes -> do + -- In this case, we want to create a parser that parses the arguments as + -- positional arguments. + baseCase <- [e|pure $(conE conName)|] + + let apps expr (_bang, _type) = do + let label = Nothing @Text + shortName = Nothing @Char + infixE (Just expr) (varE '(<*>)) (Just [e|parseFields Nothing $(lift label) $(lift shortName) Nothing|]) + + foldl' apps (pure baseCase) bangTypes + RecC conName varBangTypes -> do + -- In this case, we want to create a parser that will use the field names. + baseCase <- [e|pure $(conE conName)|] + let apps expr (fieldName, _bang, _type) = do + let fieldNameString = + nameBase fieldName + label = + Just . T.pack . fieldNameModifier $ fieldNameString + shortName = + shortNameModifier fieldNameString + infixE (Just expr) (varE '(<*>)) (Just [e|parseFields Nothing $(lift label) $(lift shortName) Nothing|]) + + foldl' apps (pure baseCase) varBangTypes + _ -> + fail $ + unlines + [ "Expected either a normal or record constructor, got: " + , "\t" <> show con + , "Other constructors are not supported yet." + ] + +getConName :: Con -> Q Name +getConName = \case + NormalC n _ -> + pure n + RecC n _ -> + pure n + other -> + fail $ + unlines + [ "Expected a normal or record constructor, got unsupported constructor: " + , "\t" <> show other + ] + +-- | This function should be called with a datatype consisting of multiple +-- constructors. The constructor will be converted into a subcommand name. +makeSubcommand :: Modifiers -> Con -> Q Exp +makeSubcommand modifiers@Modifiers {..} con = do + conName <- getConName con + singleCommandParserExpr <- makeSingleCommand modifiers con + let conNameString = + nameBase conName + name = + constructorNameModifier conNameString + + subparserFieldsExpr <- + [e| + Options.command + $(lift name) + ( Options.info (Options.helper <*> $(pure singleCommandParserExpr)) mempty + ) + <> Options.metavar $(lift name) + |] + + [e|Options.subparser $(pure subparserFieldsExpr)|] + +#if MIN_VERSION_template_haskell(2,18,0) +mkConP :: Name -> [Pat] -> Pat +mkConP name pats = ConP name [] pats +#else +mkConP :: Name -> [Pat] -> Pat +mkConP name pats = ConP name pats +#endif diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,310 @@ +{-# 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