diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ Changelog ========= +Version 0.1.0.1 +--------------- + +*June 19, 2019* + + + +* Minor rewrite to use *functor-combinators* under the hood. + Version 0.1.0.0 --------------- diff --git a/servant-cli.cabal b/servant-cli.cabal --- a/servant-cli.cabal +++ b/servant-cli.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 85f3cb39849fe82dcb28a8a8da108c99ffb6de9a912b6acd59c5a6a8ccf8793a +-- hash: cc77d286e5084052ae5e3a6a33247742fcfc01d72b8da6244b83f5d4a57f8fbb name: servant-cli -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Command line interface for Servant API clients description: Parse command line arguments into a servant client, from a servant API, using /optparse-applicative/ for parsing, displaying help, and @@ -26,6 +26,7 @@ copyright: (c) Justin Le 2019 license: BSD3 license-file: LICENSE +tested-with: GHC >= 8.4 build-type: Simple extra-source-files: README.md @@ -47,14 +48,14 @@ src ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Werror=incomplete-patterns build-depends: - base >=4.7 && <5 + base >=4.11 && <5 , bytestring , case-insensitive , containers , filepath , free + , functor-combinators , http-types - , kan-extensions , optparse-applicative , profunctors , recursion-schemes @@ -62,6 +63,7 @@ , servant-client-core >=0.15 , servant-docs , text + , transformers , vinyl default-language: Haskell2010 @@ -74,7 +76,7 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Werror=incomplete-patterns build-depends: aeson - , base >=4.7 && <5 + , base >=4.11 && <5 , bytestring , containers , http-client diff --git a/src/Servant/CLI/Internal/PStruct.hs b/src/Servant/CLI/Internal/PStruct.hs --- a/src/Servant/CLI/Internal/PStruct.hs +++ b/src/Servant/CLI/Internal/PStruct.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -42,19 +43,20 @@ , orRequired, orOptional, orSwitch ) where +import Control.Applicative.Backwards import Control.Applicative.Free import Data.Foldable import Data.Function import Data.Functor -import Data.Functor.Coyoneda -import Data.Functor.Day +import Data.Functor.Combinator +import Data.Functor.Combinator.Unsafe import Data.Functor.Foldable import Data.Functor.Foldable.TH import Data.Kind import Data.List.NonEmpty (NonEmpty(..)) import Data.Map (Map) import Data.Maybe -import GHC.Generics +import Data.Proxy import Options.Applicative import System.FilePath import qualified Data.Map as M @@ -108,7 +110,7 @@ :+: Day MultiArg EndpointMap -- | Endpoint arguments and body. -data Endpoint a = Endpoint +newtype Endpoint a = Endpoint { epStruct :: Day (Ap Opt) Parser a } deriving Functor @@ -126,11 +128,6 @@ makeBaseFunctor ''PStruct -(|+|) :: (f a -> r) -> (g a -> r) -> (f :+: g) a -> r -f |+| g = \case - L1 x -> f x - R1 y -> g y - -- | Convert a 'PStruct' into a command line argument parser, from the -- /optparse-applicative/ library. It can be run with 'execParser'. -- @@ -169,9 +166,10 @@ | otherwise = subparser $ subs <> metavar "COMPONENT" <> commandGroup "Path components:" - (nsc, cap) = maybe ([], empty) (mkArg p |+| (([],) . mkArgs)) psCapturesF - ep = methodPicker psEndpointsF - ns = psInfoF ++ nsc + cap = unsafePlus (Proxy @Parser) $ + interpret (mkArg p !*! mkArgs) $ MaybeF psCapturesF + ep = methodPicker psEndpointsF + ns = psInfoF mkHelp | toHelp = helper | otherwise = pure id @@ -181,21 +179,21 @@ -> (Bool -> [String] -> InfoMod x -> ParserInfo x) -> Mod CommandFields x mkCmd ps c p = command c (p True (ps ++ [c]) mempty) - mkArg :: [String] -> Day Arg PStruct x -> ([String], Parser x) + mkArg :: [String] -> Day Arg PStruct x -> Parser x mkArg ps (Day a p f) = - ( [] - , f <$> argParser a - <*> infoParser (structParser_ p False (ps ++ [':' : argName a]) mempty) - ) + f <$> argParser a + <*> infoParser (structParser_ p False (ps ++ [':' : argName a]) mempty) mkArgs :: Day MultiArg EndpointMap x -> Parser x - mkArgs (Day (MultiArg a) ps f) = - flip f <$> methodPicker ps - <*> many (argParser a) + mkArgs = upgradeC @Day (Proxy @Parser) $ + forwards + . ( Backwards . (\case MultiArg a -> many (argParser a)) + !*! Backwards . methodPicker + ) argParser :: Arg x -> Parser x argParser Arg{..} = argument argRead $ help argDesc <> metavar argMeta mkOpt :: Opt x -> Parser x - mkOpt Opt{..} = lowerCoyoneda $ (`hoistCoyoneda` optRead) $ \case + mkOpt Opt{..} = forI optRead $ \case ORRequired r -> option r mods OROptional r -> optional $ option r mods ORSwitch -> switch $ long optName <> help optDesc @@ -217,7 +215,9 @@ where epMap = mkEndpoint <$> eps mkEndpoint :: Endpoint x -> Parser x - mkEndpoint = dap . trans1 (runAp mkOpt) . epStruct + mkEndpoint = upgradeC @Day (Proxy @Parser) $ + binterpret (interpret mkOpt) id + . epStruct pickMethod :: HTTP.Method -> Parser x -> Mod CommandFields x pickMethod m p = command (T.unpack . T.decodeUtf8 $ m) $ info (p <**> helper) mempty mkRaw :: Endpoint (HTTP.Method -> x) -> Parser x @@ -298,7 +298,7 @@ addEndpointOpt :: Opt a -> Endpoint (a -> b) -> Endpoint b addEndpointOpt o (Endpoint (Day eo eb ef)) = - Endpoint (Day ((,) <$> liftAp o <*> eo) eb $ \(x, y) z -> ef y z x) + Endpoint (Day ((,) <$> inject o <*> eo) eb $ \(x, y) z -> ef y z x) addEPMOpt :: Opt a -> EndpointMap (a -> b) -> EndpointMap b addEPMOpt o (EPM e r) = EPM e' r' @@ -343,8 +343,8 @@ infixr 4 %:> addEndpointBody :: Parser a -> Endpoint (a -> b) -> Endpoint b -addEndpointBody b (Endpoint (Day eo eb ef)) = - Endpoint (Day eo (liftA2 (,) b eb) $ \x (y, z) -> ef x z y) +addEndpointBody b (Endpoint d) = + Endpoint (inR b <**> d) addEPMBody :: Parser a -> EndpointMap (a -> b) -> EndpointMap b addEPMBody b (EPM e r) = EPM e' r' @@ -366,14 +366,14 @@ -- | Helper to lift a 'ReadM' into something that can be used with 'optRead'. orRequired :: ReadM a -> Coyoneda OptRead a -orRequired = liftCoyoneda . ORRequired +orRequired = inject . ORRequired -- | Helper to lift an optional 'ReadM' into something that can be used -- with 'optRead'. orOptional :: ReadM a -> Coyoneda OptRead (Maybe a) -orOptional = liftCoyoneda . OROptional +orOptional = inject . OROptional -- | An 'optRead' that is on-or-off. orSwitch :: Coyoneda OptRead Bool -orSwitch = liftCoyoneda ORSwitch +orSwitch = inject ORSwitch