optparse-th (empty) → 0.1.0.0
raw patch · 7 files changed
+828/−0 lines, 7 filesdep +basedep +hspecdep +optparse-applicativesetup-changed
Dependencies added: base, hspec, optparse-applicative, optparse-generic, optparse-th, template-haskell, text
Files
- CHANGELOG.md +11/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +2/−0
- optparse-th.cabal +134/−0
- src/Options/TH.hs +335/−0
- test/Spec.hs +310/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ optparse-th.cabal view
@@ -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 <https://github.com/MercuryTechnologies/optparse-th#readme>+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
+ src/Options/TH.hs view
@@ -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
+ test/Spec.hs view
@@ -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