{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module      : Servant.CLI.PStruct
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Internal module providing a data structure for representing structure of
-- command line parsers that can be manipulated as an ADT, as well as
-- functionality to interpret it as a 'Parser' command line argument
-- parser.
module Servant.CLI.Internal.PStruct
  ( OptRead (..),
    Opt (..),
    Arg (..),
    MultiArg (..),
    Captures,
    Endpoint (..),
    EndpointMap (..),
    PStruct (..),
    PStructF (..),
    structParser,
    structParser_,

    -- * Creating
    branch,
    ($:>),
    (%:>),
    (?:>),
    (#:>),
    (##:>),
    note,
    endpoint,
    rawEndpoint,

    -- ** Readers
    orRequired,
    orOptional,
    orSwitch,
  )
where

import Control.Applicative.Backwards
import Control.Applicative.Free
import Data.Foldable
import Data.Function
import Data.Functor
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 qualified Data.Map as M
import Data.Maybe
import Data.Proxy
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Types as HTTP
import Options.Applicative
import qualified Options.Applicative.Help.Pretty as O
import System.FilePath

-- | How to "read" an option.
data OptRead :: Type -> Type where
  ORRequired :: ReadM a -> OptRead a
  OROptional :: ReadM a -> OptRead (Maybe a)
  ORSwitch :: OptRead Bool

-- | Query parameters are interpreted as options
data Opt a = Opt
  { forall a. Opt a -> String
optName :: String,
    forall a. Opt a -> String
optDesc :: String,
    forall a. Opt a -> String
optMeta :: String,
    forall a. Opt a -> Maybe (NonEmpty String)
optVals :: Maybe (NonEmpty String),
    forall a. Opt a -> Coyoneda OptRead a
optRead :: Coyoneda OptRead a
  }
  deriving ((forall a b. (a -> b) -> Opt a -> Opt b)
-> (forall a b. a -> Opt b -> Opt a) -> Functor Opt
forall a b. a -> Opt b -> Opt a
forall a b. (a -> b) -> Opt a -> Opt b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Opt a -> Opt b
fmap :: forall a b. (a -> b) -> Opt a -> Opt b
$c<$ :: forall a b. a -> Opt b -> Opt a
<$ :: forall a b. a -> Opt b -> Opt a
Functor)

-- | Captures are interpreted as arguments
data Arg a = Arg
  { forall a. Arg a -> String
argName :: String,
    forall a. Arg a -> String
argDesc :: String,
    forall a. Arg a -> String
argMeta :: String,
    forall a. Arg a -> ReadM a
argRead :: ReadM a
  }
  deriving ((forall a b. (a -> b) -> Arg a -> Arg b)
-> (forall a b. a -> Arg b -> Arg a) -> Functor Arg
forall a b. a -> Arg b -> Arg a
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Arg a -> Arg b
fmap :: forall a b. (a -> b) -> Arg a -> Arg b
$c<$ :: forall a b. a -> Arg b -> Arg a
<$ :: forall a b. a -> Arg b -> Arg a
Functor)

-- | Interpret an 'Arg' as something that can be given repeatedly an
-- arbitrary number of times.
data MultiArg :: Type -> Type where
  MultiArg :: Arg a -> MultiArg [a]

-- | A map of endpoints associated with methods, paired with an optional
-- "raw" endpoint.
data EndpointMap a = EPM
  { forall a. EndpointMap a -> Map Method (Endpoint a)
epmGiven :: Map HTTP.Method (Endpoint a),
    forall a. EndpointMap a -> Maybe (Endpoint (Method -> a))
epmRaw :: Maybe (Endpoint (HTTP.Method -> a))
  }
  deriving ((forall a b. (a -> b) -> EndpointMap a -> EndpointMap b)
-> (forall a b. a -> EndpointMap b -> EndpointMap a)
-> Functor EndpointMap
forall a b. a -> EndpointMap b -> EndpointMap a
forall a b. (a -> b) -> EndpointMap a -> EndpointMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> EndpointMap a -> EndpointMap b
fmap :: forall a b. (a -> b) -> EndpointMap a -> EndpointMap b
$c<$ :: forall a b. a -> EndpointMap b -> EndpointMap a
<$ :: forall a b. a -> EndpointMap b -> EndpointMap a
Functor)

-- | Captures can be a single capture leading to the next level, or
-- a multi-capture leading to an endpoint action.
type Captures =
  Day Arg PStruct
    :+: Day MultiArg EndpointMap

-- | Endpoint arguments and body.
newtype Endpoint a = Endpoint
  {forall a. Endpoint a -> Day (Ap Opt) Parser a
epStruct :: Day (Ap Opt) Parser a}
  deriving ((forall a b. (a -> b) -> Endpoint a -> Endpoint b)
-> (forall a b. a -> Endpoint b -> Endpoint a) -> Functor Endpoint
forall a b. a -> Endpoint b -> Endpoint a
forall a b. (a -> b) -> Endpoint a -> Endpoint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Endpoint a -> Endpoint b
fmap :: forall a b. (a -> b) -> Endpoint a -> Endpoint b
$c<$ :: forall a b. a -> Endpoint b -> Endpoint a
<$ :: forall a b. a -> Endpoint b -> Endpoint a
Functor)

-- | Structure for a parser of a given value that may use items from
-- captures and arguments.
data PStruct a = PStruct
  { forall a. PStruct a -> [String]
psInfo :: [String],
    -- | path components
    forall a. PStruct a -> Map String (PStruct a)
psComponents :: Map String (PStruct a),
    -- | captures
    forall a. PStruct a -> Maybe (Captures a)
psCaptures :: Maybe (Captures a),
    forall a. PStruct a -> EndpointMap a
psEndpoints :: EndpointMap a
  }
  deriving ((forall a b. (a -> b) -> PStruct a -> PStruct b)
-> (forall a b. a -> PStruct b -> PStruct a) -> Functor PStruct
forall a b. a -> PStruct b -> PStruct a
forall a b. (a -> b) -> PStruct a -> PStruct b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PStruct a -> PStruct b
fmap :: forall a b. (a -> b) -> PStruct a -> PStruct b
$c<$ :: forall a b. a -> PStruct b -> PStruct a
<$ :: forall a b. a -> PStruct b -> PStruct a
Functor)

-- TODO: Capture vs. Endpoint interplay is a bit weird, when they are at
-- the same level.

makeBaseFunctor ''PStruct

-- | Convert a 'PStruct' into a command line argument parser, from the
-- /optparse-applicative/ library.  It can be run with 'execParser'.
--
-- It takes options on how the top-level prompt is displayed when given
-- @"--help"@; it can be useful for adding a header or program description.
-- Otherwise, just use 'mempty'.
structParser ::
  -- | The 'PStruct' to convert.
  PStruct a ->
  -- | Modify how the top-level prompt is displayed.
  InfoMod a ->
  ParserInfo a
structParser :: forall a. PStruct a -> InfoMod a -> ParserInfo a
structParser = (InfoMod a -> PStruct a -> ParserInfo a)
-> PStruct a -> InfoMod a -> ParserInfo a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((InfoMod a -> PStruct a -> ParserInfo a)
 -> PStruct a -> InfoMod a -> ParserInfo a)
-> (InfoMod a -> PStruct a -> ParserInfo a)
-> PStruct a
-> InfoMod a
-> ParserInfo a
forall a b. (a -> b) -> a -> b
$ \InfoMod a
im -> ((InfoMod a -> ParserInfo a) -> InfoMod a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$ InfoMod a
im) ((InfoMod a -> ParserInfo a) -> ParserInfo a)
-> (PStruct a -> InfoMod a -> ParserInfo a)
-> PStruct a
-> ParserInfo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String] -> InfoMod a -> ParserInfo a)
-> [String] -> InfoMod a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$ []) (([String] -> InfoMod a -> ParserInfo a)
 -> InfoMod a -> ParserInfo a)
-> (PStruct a -> [String] -> InfoMod a -> ParserInfo a)
-> PStruct a
-> InfoMod a
-> ParserInfo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool -> [String] -> InfoMod a -> ParserInfo a)
-> Bool -> [String] -> InfoMod a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$ Bool
True) ((Bool -> [String] -> InfoMod a -> ParserInfo a)
 -> [String] -> InfoMod a -> ParserInfo a)
-> (PStruct a -> Bool -> [String] -> InfoMod a -> ParserInfo a)
-> PStruct a
-> [String]
-> InfoMod a
-> ParserInfo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PStruct a -> Bool -> [String] -> InfoMod a -> ParserInfo a
forall a.
PStruct a -> Bool -> [String] -> InfoMod a -> ParserInfo a
structParser_

-- | Low-level implementation of 'structParser'.
structParser_ ::
  PStruct a ->
  -- | add helper
  Bool ->
  -- | root path
  [String] ->
  -- | modify top level
  InfoMod a ->
  ParserInfo a
structParser_ :: forall a.
PStruct a -> Bool -> [String] -> InfoMod a -> ParserInfo a
structParser_ = (Base (PStruct a) (Bool -> [String] -> InfoMod a -> ParserInfo a)
 -> Bool -> [String] -> InfoMod a -> ParserInfo a)
-> PStruct a -> Bool -> [String] -> InfoMod a -> ParserInfo a
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base (PStruct a) a -> a) -> PStruct a -> a
cata Base (PStruct a) (Bool -> [String] -> InfoMod a -> ParserInfo a)
-> Bool -> [String] -> InfoMod a -> ParserInfo a
PStructF a (Bool -> [String] -> InfoMod a -> ParserInfo a)
-> Bool -> [String] -> InfoMod a -> ParserInfo a
forall x.
PStructF x (Bool -> [String] -> InfoMod x -> ParserInfo x)
-> Bool -> [String] -> InfoMod x -> ParserInfo x
go
  where
    go ::
      PStructF x (Bool -> [String] -> InfoMod x -> ParserInfo x) ->
      Bool ->
      [String] ->
      InfoMod x ->
      ParserInfo x
    go :: forall x.
PStructF x (Bool -> [String] -> InfoMod x -> ParserInfo x)
-> Bool -> [String] -> InfoMod x -> ParserInfo x
go PStructF {[String]
Maybe ((:+:) (Day Arg PStruct) (Day MultiArg EndpointMap) x)
Map String (Bool -> [String] -> InfoMod x -> ParserInfo x)
EndpointMap x
psInfoF :: forall a r. PStructF a r -> [String]
psComponentsF :: forall a r. PStructF a r -> Map String r
psCapturesF :: forall a r. PStructF a r -> Maybe (Captures a)
psEndpointsF :: forall a r. PStructF a r -> EndpointMap a
psInfoF :: [String]
psComponentsF :: Map String (Bool -> [String] -> InfoMod x -> ParserInfo x)
psCapturesF :: Maybe ((:+:) (Day Arg PStruct) (Day MultiArg EndpointMap) x)
psEndpointsF :: EndpointMap x
..} Bool
toHelp [String]
p InfoMod x
im =
      Parser x -> InfoMod x -> ParserInfo x
forall a. Parser a -> InfoMod a -> ParserInfo a
info ((Parser x
subp Parser x -> Parser x -> Parser x
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser x
cap Parser x -> Parser x -> Parser x
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser x
ep) Parser x -> Parser (x -> x) -> Parser x
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (x -> x)
mkHelp) (InfoMod x -> ParserInfo x) -> InfoMod x -> ParserInfo x
forall a b. (a -> b) -> a -> b
$
        InfoMod x
forall a. InfoMod a
fullDesc
          InfoMod x -> InfoMod x -> InfoMod x
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod x
forall a. String -> InfoMod a
header ([String] -> String
joinPath [String]
p)
          InfoMod x -> InfoMod x -> InfoMod x
forall a. Semigroup a => a -> a -> a
<> Maybe Doc -> InfoMod x
forall a. Maybe Doc -> InfoMod a
progDescDoc (Doc -> Maybe Doc
forall a. a -> Maybe a
Just ([Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
O.vcat ([Doc] -> Doc) -> ([String] -> [Doc]) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
O.pretty ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ [String]
ns))
          InfoMod x -> InfoMod x -> InfoMod x
forall a. Semigroup a => a -> a -> a
<> InfoMod x
im
      where
        subs :: Mod CommandFields x
subs = (String
 -> (Bool -> [String] -> InfoMod x -> ParserInfo x)
 -> Mod CommandFields x)
-> Map String (Bool -> [String] -> InfoMod x -> ParserInfo x)
-> Mod CommandFields x
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
M.foldMapWithKey ([String]
-> String
-> (Bool -> [String] -> InfoMod x -> ParserInfo x)
-> Mod CommandFields x
forall x.
[String]
-> String
-> (Bool -> [String] -> InfoMod x -> ParserInfo x)
-> Mod CommandFields x
mkCmd [String]
p) Map String (Bool -> [String] -> InfoMod x -> ParserInfo x)
psComponentsF
        subp :: Parser x
subp
          | Map String (Bool -> [String] -> InfoMod x -> ParserInfo x) -> Bool
forall k a. Map k a -> Bool
M.null Map String (Bool -> [String] -> InfoMod x -> ParserInfo x)
psComponentsF = Parser x
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty
          | Bool
otherwise =
              Mod CommandFields x -> Parser x
forall a. Mod CommandFields a -> Parser a
subparser (Mod CommandFields x -> Parser x)
-> Mod CommandFields x -> Parser x
forall a b. (a -> b) -> a -> b
$
                Mod CommandFields x
subs
                  Mod CommandFields x -> Mod CommandFields x -> Mod CommandFields x
forall a. Semigroup a => a -> a -> a
<> String -> Mod CommandFields x
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"COMPONENT"
                  Mod CommandFields x -> Mod CommandFields x -> Mod CommandFields x
forall a. Semigroup a => a -> a -> a
<> String -> Mod CommandFields x
forall a. String -> Mod CommandFields a
commandGroup String
"Path components:"
        cap :: Parser x
cap =
          Proxy Parser -> (Plus Parser => Parser x) -> Parser x
forall (f :: * -> *) (proxy :: (* -> *) -> *) r.
Alternative f =>
proxy f -> (Plus f => r) -> r
unsafePlus (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @Parser) ((Plus Parser => Parser x) -> Parser x)
-> (Plus Parser => Parser x) -> Parser x
forall a b. (a -> b) -> a -> b
$
            ((Day Arg PStruct :+: Day MultiArg EndpointMap) ~> Parser)
-> MaybeF (Day Arg PStruct :+: Day MultiArg EndpointMap) ~> Parser
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
Interpret t f =>
(g ~> f) -> t g ~> f
forall (g :: * -> *). (g ~> Parser) -> MaybeF g ~> Parser
interpret ([String] -> Day Arg PStruct x -> Parser x
forall x. [String] -> Day Arg PStruct x -> Parser x
mkArg [String]
p (forall {x}. Day Arg PStruct x -> Parser x)
-> (Day MultiArg EndpointMap ~> Parser)
-> (Day Arg PStruct :+: Day MultiArg EndpointMap) ~> Parser
forall (t :: (* -> *) -> (* -> *) -> * -> *) (h :: * -> *)
       (f :: * -> *) (g :: * -> *).
SemigroupIn t h =>
(f ~> h) -> (g ~> h) -> t f g ~> h
!*! Day MultiArg EndpointMap x -> Parser x
Day MultiArg EndpointMap ~> Parser
mkArgs) (MaybeF (Day Arg PStruct :+: Day MultiArg EndpointMap) x
 -> Parser x)
-> MaybeF (Day Arg PStruct :+: Day MultiArg EndpointMap) x
-> Parser x
forall a b. (a -> b) -> a -> b
$
              Maybe ((:+:) (Day Arg PStruct) (Day MultiArg EndpointMap) x)
-> MaybeF (Day Arg PStruct :+: Day MultiArg EndpointMap) x
forall {k} (f :: k -> *) (a :: k). Maybe (f a) -> MaybeF f a
MaybeF Maybe ((:+:) (Day Arg PStruct) (Day MultiArg EndpointMap) x)
psCapturesF
        ep :: Parser x
ep = EndpointMap x -> Parser x
forall x. EndpointMap x -> Parser x
methodPicker EndpointMap x
psEndpointsF
        ns :: [String]
ns = [String]
psInfoF
        mkHelp :: Parser (x -> x)
mkHelp
          | Bool
toHelp = Parser (x -> x)
forall a. Parser (a -> a)
helper
          | Bool
otherwise = (x -> x) -> Parser (x -> x)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> x
forall a. a -> a
id
    mkCmd ::
      [String] ->
      String ->
      (Bool -> [String] -> InfoMod x -> ParserInfo x) ->
      Mod CommandFields x
    mkCmd :: forall x.
[String]
-> String
-> (Bool -> [String] -> InfoMod x -> ParserInfo x)
-> Mod CommandFields x
mkCmd [String]
ps String
c Bool -> [String] -> InfoMod x -> ParserInfo x
p = String -> ParserInfo x -> Mod CommandFields x
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
c (Bool -> [String] -> InfoMod x -> ParserInfo x
p Bool
True ([String]
ps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
c]) InfoMod x
forall a. Monoid a => a
mempty)
    mkArg :: [String] -> Day Arg PStruct x -> Parser x
    mkArg :: forall x. [String] -> Day Arg PStruct x -> Parser x
mkArg [String]
ps (Day Arg b
a PStruct c
p b -> c -> x
f) =
      b -> c -> x
f
        (b -> c -> x) -> Parser b -> Parser (c -> x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg b -> Parser b
forall x. Arg x -> Parser x
argParser Arg b
a
        Parser (c -> x) -> Parser c -> Parser x
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParserInfo c -> Parser c
forall a. ParserInfo a -> Parser a
infoParser (PStruct c -> Bool -> [String] -> InfoMod c -> ParserInfo c
forall a.
PStruct a -> Bool -> [String] -> InfoMod a -> ParserInfo a
structParser_ PStruct c
p Bool
False ([String]
ps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Arg b -> String
forall a. Arg a -> String
argName Arg b
a]) InfoMod c
forall a. Monoid a => a
mempty)
    mkArgs :: Day MultiArg EndpointMap x -> Parser x
    mkArgs :: Day MultiArg EndpointMap ~> Parser
mkArgs =
      Proxy Parser
-> (Apply Parser => Day MultiArg EndpointMap x -> Parser x)
-> Day MultiArg EndpointMap x
-> Parser x
forall (f :: * -> *) (proxy :: (* -> *) -> *) r.
Applicative f =>
proxy f -> (Apply f => r) -> r
unsafeApply (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @Parser) ((Apply Parser => Day MultiArg EndpointMap x -> Parser x)
 -> Day MultiArg EndpointMap x -> Parser x)
-> (Apply Parser => Day MultiArg EndpointMap x -> Parser x)
-> Day MultiArg EndpointMap x
-> Parser x
forall a b. (a -> b) -> a -> b
$
        Backwards Parser x -> Parser x
forall {k} (f :: k -> *) (a :: k). Backwards f a -> f a
forwards
          (Backwards Parser x -> Parser x)
-> (Day MultiArg EndpointMap x -> Backwards Parser x)
-> Day MultiArg EndpointMap x
-> Parser x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( Parser x -> Backwards Parser x
forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (Parser x -> Backwards Parser x)
-> (MultiArg x -> Parser x) -> MultiArg x -> Backwards Parser x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\case MultiArg Arg a
a -> Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Arg a -> Parser a
forall x. Arg x -> Parser x
argParser Arg a
a))
                (forall {x}. MultiArg x -> Backwards Parser x)
-> (EndpointMap ~> Backwards Parser)
-> Day MultiArg EndpointMap ~> Backwards Parser
forall (t :: (* -> *) -> (* -> *) -> * -> *) (h :: * -> *)
       (f :: * -> *) (g :: * -> *).
SemigroupIn t h =>
(f ~> h) -> (g ~> h) -> t f g ~> h
!*! Parser x -> Backwards Parser x
forall {k} (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (Parser x -> Backwards Parser x)
-> (EndpointMap x -> Parser x)
-> EndpointMap x
-> Backwards Parser x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EndpointMap x -> Parser x
forall x. EndpointMap x -> Parser x
methodPicker
            )
    argParser :: Arg x -> Parser x
    argParser :: forall x. Arg x -> Parser x
argParser Arg {String
ReadM x
argName :: forall a. Arg a -> String
argDesc :: forall a. Arg a -> String
argMeta :: forall a. Arg a -> String
argRead :: forall a. Arg a -> ReadM a
argName :: String
argDesc :: String
argMeta :: String
argRead :: ReadM x
..} =
      ReadM x -> Mod ArgumentFields x -> Parser x
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM x
argRead (Mod ArgumentFields x -> Parser x)
-> Mod ArgumentFields x -> Parser x
forall a b. (a -> b) -> a -> b
$
        String -> Mod ArgumentFields x
forall (f :: * -> *) a. String -> Mod f a
help String
argDesc
          Mod ArgumentFields x
-> Mod ArgumentFields x -> Mod ArgumentFields x
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields x
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
argMeta
    mkOpt :: Opt x -> Parser x
    mkOpt :: forall x. Opt x -> Parser x
mkOpt Opt {String
Maybe (NonEmpty String)
Coyoneda OptRead x
optName :: forall a. Opt a -> String
optDesc :: forall a. Opt a -> String
optMeta :: forall a. Opt a -> String
optVals :: forall a. Opt a -> Maybe (NonEmpty String)
optRead :: forall a. Opt a -> Coyoneda OptRead a
optName :: String
optDesc :: String
optMeta :: String
optVals :: Maybe (NonEmpty String)
optRead :: Coyoneda OptRead x
..} = Coyoneda OptRead x
-> (forall {x}. OptRead x -> Parser x) -> Parser x
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *)
       (a :: k).
Interpret t f =>
t g a -> (g ~> f) -> f a
forI Coyoneda OptRead x
optRead ((forall {x}. OptRead x -> Parser x) -> Parser x)
-> (forall {x}. OptRead x -> Parser x) -> Parser x
forall a b. (a -> b) -> a -> b
$ \case
      ORRequired ReadM x
r -> ReadM x -> Mod OptionFields x -> Parser x
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM x
r Mod OptionFields x
forall y. Mod OptionFields y
mods
      OROptional ReadM a
r -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser a -> Parser (Maybe a)) -> Parser a -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ ReadM a -> Mod OptionFields a -> Parser a
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM a
r Mod OptionFields a
forall y. Mod OptionFields y
mods
      OptRead x
ORSwitch -> Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
optName Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
optDesc
      where
        mods :: Mod OptionFields y
        mods :: forall y. Mod OptionFields y
mods =
          String -> Mod OptionFields y
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
optName
            Mod OptionFields y -> Mod OptionFields y -> Mod OptionFields y
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields y
forall (f :: * -> *) a. String -> Mod f a
help String
optDesc
            Mod OptionFields y -> Mod OptionFields y -> Mod OptionFields y
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields y
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
optMeta
            Mod OptionFields y -> Mod OptionFields y -> Mod OptionFields y
forall a. Semigroup a => a -> a -> a
<> (NonEmpty String -> Mod OptionFields y)
-> Maybe (NonEmpty String) -> Mod OptionFields y
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([String] -> Mod OptionFields y
forall (f :: * -> *) a. HasCompleter f => [String] -> Mod f a
completeWith ([String] -> Mod OptionFields y)
-> (NonEmpty String -> [String])
-> NonEmpty String
-> Mod OptionFields y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) Maybe (NonEmpty String)
optVals
    methodPicker :: EndpointMap x -> Parser x
    methodPicker :: forall x. EndpointMap x -> Parser x
methodPicker (EPM Map Method (Endpoint x)
eps Maybe (Endpoint (Method -> x))
rw) = case Map Method (Parser x) -> Maybe (Parser x, Map Method (Parser x))
forall k a. Map k a -> Maybe (a, Map k a)
M.minView Map Method (Parser x)
epMap of
      Maybe (Parser x, Map Method (Parser x))
Nothing -> Parser x
-> (Endpoint (Method -> x) -> Parser x)
-> Maybe (Endpoint (Method -> x))
-> Parser x
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser x
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty Endpoint (Method -> x) -> Parser x
forall x. Endpoint (Method -> x) -> Parser x
mkRaw Maybe (Endpoint (Method -> x))
rw
      Just (Parser x
m0, Map Method (Parser x)
ms)
        | Map Method (Parser x) -> Bool
forall k a. Map k a -> Bool
M.null Map Method (Parser x)
ms Bool -> Bool -> Bool
&& Maybe (Endpoint (Method -> x)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Endpoint (Method -> x))
rw -> Parser x
m0
        | Bool
otherwise ->
            Mod CommandFields x -> Parser x
forall a. Mod CommandFields a -> Parser a
subparser (Mod CommandFields x -> Parser x)
-> Mod CommandFields x -> Parser x
forall a b. (a -> b) -> a -> b
$
              (Method -> Parser x -> Mod CommandFields x)
-> Map Method (Parser x) -> Mod CommandFields x
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
M.foldMapWithKey Method -> Parser x -> Mod CommandFields x
forall x. Method -> Parser x -> Mod CommandFields x
pickMethod Map Method (Parser x)
epMap
                Mod CommandFields x -> Mod CommandFields x -> Mod CommandFields x
forall a. Semigroup a => a -> a -> a
<> (Endpoint (Method -> x) -> Mod CommandFields x)
-> Maybe (Endpoint (Method -> x)) -> Mod CommandFields x
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Endpoint (Method -> x) -> Mod CommandFields x
forall x. Endpoint (Method -> x) -> Mod CommandFields x
mkRawCommand Maybe (Endpoint (Method -> x))
rw
                Mod CommandFields x -> Mod CommandFields x -> Mod CommandFields x
forall a. Semigroup a => a -> a -> a
<> String -> Mod CommandFields x
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"METHOD"
                Mod CommandFields x -> Mod CommandFields x -> Mod CommandFields x
forall a. Semigroup a => a -> a -> a
<> String -> Mod CommandFields x
forall a. String -> Mod CommandFields a
commandGroup String
"HTTP Methods:"
      where
        epMap :: Map Method (Parser x)
epMap = Endpoint x -> Parser x
forall x. Endpoint x -> Parser x
mkEndpoint (Endpoint x -> Parser x)
-> Map Method (Endpoint x) -> Map Method (Parser x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Method (Endpoint x)
eps
    mkEndpoint :: Endpoint x -> Parser x
    mkEndpoint :: forall x. Endpoint x -> Parser x
mkEndpoint =
      Proxy Parser
-> (Apply Parser => Endpoint x -> Parser x)
-> Endpoint x
-> Parser x
forall (f :: * -> *) (proxy :: (* -> *) -> *) r.
Applicative f =>
proxy f -> (Apply f => r) -> r
unsafeApply (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @Parser) ((Apply Parser => Endpoint x -> Parser x)
 -> Endpoint x -> Parser x)
-> (Apply Parser => Endpoint x -> Parser x)
-> Endpoint x
-> Parser x
forall a b. (a -> b) -> a -> b
$
        (Ap Opt ~> Parser)
-> (Parser ~> Parser) -> Day (Ap Opt) Parser ~> Parser
forall (g :: * -> *) (h :: * -> *).
(g ~> Parser) -> (h ~> Parser) -> Day g h ~> Parser
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
SemigroupIn t f =>
(g ~> f) -> (h ~> f) -> t g h ~> f
binterpret ((forall x. Opt x -> Parser x) -> Ap Opt ~> Parser
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
Interpret t f =>
(g ~> f) -> t g ~> f
forall (g :: * -> *). (g ~> Parser) -> Ap g ~> Parser
interpret Opt x -> Parser x
forall x. Opt x -> Parser x
mkOpt) Parser x -> Parser x
forall a. a -> a
Parser ~> Parser
id
          (Day (Ap Opt) Parser x -> Parser x)
-> (Endpoint x -> Day (Ap Opt) Parser x) -> Endpoint x -> Parser x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endpoint x -> Day (Ap Opt) Parser x
forall a. Endpoint a -> Day (Ap Opt) Parser a
epStruct
    pickMethod :: HTTP.Method -> Parser x -> Mod CommandFields x
    pickMethod :: forall x. Method -> Parser x -> Mod CommandFields x
pickMethod Method
m Parser x
p = String -> ParserInfo x -> Mod CommandFields x
forall a. String -> ParserInfo a -> Mod CommandFields a
command (Text -> String
T.unpack (Text -> String) -> (Method -> Text) -> Method -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
T.decodeUtf8 (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Method
m) (ParserInfo x -> Mod CommandFields x)
-> ParserInfo x -> Mod CommandFields x
forall a b. (a -> b) -> a -> b
$ Parser x -> InfoMod x -> ParserInfo x
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser x
p Parser x -> Parser (x -> x) -> Parser x
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (x -> x)
forall a. Parser (a -> a)
helper) InfoMod x
forall a. Monoid a => a
mempty
    mkRaw :: Endpoint (HTTP.Method -> x) -> Parser x
    mkRaw :: forall x. Endpoint (Method -> x) -> Parser x
mkRaw Endpoint (Method -> x)
e = Endpoint (Method -> x) -> Parser (Method -> x)
forall x. Endpoint x -> Parser x
mkEndpoint Endpoint (Method -> x)
e Parser (Method -> x) -> Parser Method -> Parser x
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Method
o
      where
        o :: Parser Method
o =
          forall s. IsString s => Mod OptionFields s -> Parser s
strOption @HTTP.Method (Mod OptionFields Method -> Parser Method)
-> Mod OptionFields Method -> Parser Method
forall a b. (a -> b) -> a -> b
$
            String -> Mod OptionFields Method
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"method"
              Mod OptionFields Method
-> Mod OptionFields Method -> Mod OptionFields Method
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Method
forall (f :: * -> *) a. String -> Mod f a
help String
"method for raw request (GET, POST, etc.)"
              Mod OptionFields Method
-> Mod OptionFields Method -> Mod OptionFields Method
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Method
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"METHOD"
              Mod OptionFields Method
-> Mod OptionFields Method -> Mod OptionFields Method
forall a. Semigroup a => a -> a -> a
<> [String] -> Mod OptionFields Method
forall (f :: * -> *) a. HasCompleter f => [String] -> Mod f a
completeWith (StdMethod -> String
forall a. Show a => a -> String
show (StdMethod -> String) -> [StdMethod] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StdMethod
HTTP.GET ..])
    mkRawCommand :: Endpoint (HTTP.Method -> x) -> Mod CommandFields x
    mkRawCommand :: forall x. Endpoint (Method -> x) -> Mod CommandFields x
mkRawCommand Endpoint (Method -> x)
d = String -> ParserInfo x -> Mod CommandFields x
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"RAW" (ParserInfo x -> Mod CommandFields x)
-> ParserInfo x -> Mod CommandFields x
forall a b. (a -> b) -> a -> b
$ Parser x -> InfoMod x -> ParserInfo x
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Endpoint (Method -> x) -> Parser x
forall x. Endpoint (Method -> x) -> Parser x
mkRaw Endpoint (Method -> x)
d Parser x -> Parser (x -> x) -> Parser x
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (x -> x)
forall a. Parser (a -> a)
helper) InfoMod x
forall a. Monoid a => a
mempty

-- | Combine two 'EndpointMap's, preferring the left hand side for
-- conflicts.  If the left hand has a raw endpoint, the right hand's
-- endpoints are ignored.
instance Semigroup (EndpointMap a) where
  <> :: EndpointMap a -> EndpointMap a -> EndpointMap a
(<>) = EndpointMap a -> EndpointMap a -> EndpointMap a
forall a. EndpointMap a -> EndpointMap a -> EndpointMap a
altEPM

instance Monoid (EndpointMap a) where
  mempty :: EndpointMap a
mempty = Map Method (Endpoint a)
-> Maybe (Endpoint (Method -> a)) -> EndpointMap a
forall a.
Map Method (Endpoint a)
-> Maybe (Endpoint (Method -> a)) -> EndpointMap a
EPM Map Method (Endpoint a)
forall k a. Map k a
M.empty Maybe (Endpoint (Method -> a))
forall a. Maybe a
Nothing

altEPM :: EndpointMap a -> EndpointMap a -> EndpointMap a
altEPM :: forall a. EndpointMap a -> EndpointMap a -> EndpointMap a
altEPM (EPM Map Method (Endpoint a)
e1 Maybe (Endpoint (Method -> a))
r1) (EPM Map Method (Endpoint a)
e2 Maybe (Endpoint (Method -> a))
r2) = Map Method (Endpoint a)
-> Maybe (Endpoint (Method -> a)) -> EndpointMap a
forall a.
Map Method (Endpoint a)
-> Maybe (Endpoint (Method -> a)) -> EndpointMap a
EPM Map Method (Endpoint a)
e3 Maybe (Endpoint (Method -> a))
r3
  where
    e3 :: Map Method (Endpoint a)
e3 = case Maybe (Endpoint (Method -> a))
r1 of
      Just Endpoint (Method -> a)
_ -> Map Method (Endpoint a)
e1
      Maybe (Endpoint (Method -> a))
Nothing -> (Endpoint a -> Endpoint a -> Endpoint a)
-> Map Method (Endpoint a)
-> Map Method (Endpoint a)
-> Map Method (Endpoint a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Endpoint a -> Endpoint a -> Endpoint a
forall a b. a -> b -> a
const Map Method (Endpoint a)
e1 Map Method (Endpoint a)
e2
    r3 :: Maybe (Endpoint (Method -> a))
r3 = Maybe (Endpoint (Method -> a))
r1 Maybe (Endpoint (Method -> a))
-> Maybe (Endpoint (Method -> a)) -> Maybe (Endpoint (Method -> a))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Endpoint (Method -> a))
r2

altPStruct :: PStruct a -> PStruct a -> PStruct a
altPStruct :: forall a. PStruct a -> PStruct a -> PStruct a
altPStruct (PStruct [String]
ns1 Map String (PStruct a)
cs1 Maybe (Captures a)
c1 EndpointMap a
ep1) (PStruct [String]
ns2 Map String (PStruct a)
cs2 Maybe (Captures a)
c2 EndpointMap a
ep2) =
  [String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
forall a.
[String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
PStruct [String]
ns3 Map String (PStruct a)
cs3 Maybe (Captures a)
c3 EndpointMap a
ep3
  where
    ns3 :: [String]
ns3 = [String]
ns1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ns2 -- ??
    cs3 :: Map String (PStruct a)
cs3 = case Maybe (Captures a)
c1 of
      Just Captures a
_ -> Map String (PStruct a)
cs1
      Maybe (Captures a)
Nothing -> (PStruct a -> PStruct a -> PStruct a)
-> Map String (PStruct a)
-> Map String (PStruct a)
-> Map String (PStruct a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith PStruct a -> PStruct a -> PStruct a
forall a. PStruct a -> PStruct a -> PStruct a
altPStruct Map String (PStruct a)
cs1 Map String (PStruct a)
cs2
    c3 :: Maybe (Captures a)
c3 = Maybe (Captures a)
c1 Maybe (Captures a) -> Maybe (Captures a) -> Maybe (Captures a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Captures a)
c2
    ep3 :: EndpointMap a
ep3 = EndpointMap a
ep1 EndpointMap a -> EndpointMap a -> EndpointMap a
forall a. Semigroup a => a -> a -> a
<> EndpointMap a
ep2

-- | Combine two 'PStruct's, preferring the left hand side for conflicts.
-- If the left hand has a capture, the right hand's components are ignored.
-- If the left hand has a raw endpoint, the right hand's endpoints are
-- ignored.
instance Semigroup (PStruct a) where
  <> :: PStruct a -> PStruct a -> PStruct a
(<>) = PStruct a -> PStruct a -> PStruct a
forall a. PStruct a -> PStruct a -> PStruct a
altPStruct

instance Monoid (PStruct a) where
  mempty :: PStruct a
mempty = [String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
forall a.
[String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
PStruct [] Map String (PStruct a)
forall k a. Map k a
M.empty Maybe (Captures a)
forall a. Maybe a
Nothing EndpointMap a
forall a. Monoid a => a
mempty

-- | Combine two 'PStruct's in an either-or fashion, favoring the left hand
-- side.
branch :: PStruct a -> PStruct b -> PStruct (Either a b)
branch :: forall a b. PStruct a -> PStruct b -> PStruct (Either a b)
branch PStruct a
x PStruct b
y = (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> PStruct a -> PStruct (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PStruct a
x) PStruct (Either a b)
-> PStruct (Either a b) -> PStruct (Either a b)
forall a. PStruct a -> PStruct a -> PStruct a
`altPStruct` (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> PStruct b -> PStruct (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PStruct b
y)

infixr 3 `branch`

-- | Shift by a path component.
($:>) :: String -> PStruct a -> PStruct a
String
c $:> :: forall a. String -> PStruct a -> PStruct a
$:> PStruct a
p = PStruct a
forall a. Monoid a => a
mempty {psComponents = M.singleton c p}

infixr 4 $:>

-- | Add a command-line option to all endpoints.
(?:>) :: Opt a -> PStruct (a -> b) -> PStruct b
Opt a
o ?:> :: forall a b. Opt a -> PStruct (a -> b) -> PStruct b
?:> PStruct [String]
ns Map String (PStruct (a -> b))
cs Maybe (Captures (a -> b))
c EndpointMap (a -> b)
ep = [String]
-> Map String (PStruct b)
-> Maybe (Captures b)
-> EndpointMap b
-> PStruct b
forall a.
[String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
PStruct [String]
ns Map String (PStruct b)
cs' Maybe (Captures b)
c' EndpointMap b
ep'
  where
    cs' :: Map String (PStruct b)
cs' = (Opt a
o Opt a -> PStruct (a -> b) -> PStruct b
forall a b. Opt a -> PStruct (a -> b) -> PStruct b
?:>) (PStruct (a -> b) -> PStruct b)
-> Map String (PStruct (a -> b)) -> Map String (PStruct b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String (PStruct (a -> b))
cs
    c' :: Maybe (Captures b)
c' =
      Maybe (Captures (a -> b))
c Maybe (Captures (a -> b))
-> (Captures (a -> b) -> Captures b) -> Maybe (Captures b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        L1 (Day Arg b
a PStruct c
p b -> c -> a -> b
f) ->
          let f' :: c -> a -> b -> b
f' c
x a
y b
z = b -> c -> a -> b
f b
z c
x a
y
           in Day Arg PStruct b -> Captures b
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Day Arg PStruct b -> Captures b)
-> Day Arg PStruct b -> Captures b
forall a b. (a -> b) -> a -> b
$ Arg b
-> PStruct (b -> b) -> (b -> (b -> b) -> b) -> Day Arg PStruct b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day Arg b
a (Opt a
o Opt a -> PStruct (a -> b -> b) -> PStruct (b -> b)
forall a b. Opt a -> PStruct (a -> b) -> PStruct b
?:> (c -> a -> b -> b
f' (c -> a -> b -> b) -> PStruct c -> PStruct (a -> b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PStruct c
p)) b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
(&)
        R1 (Day MultiArg b
a EndpointMap c
p b -> c -> a -> b
f) ->
          let f' :: c -> a -> b -> b
f' c
x a
y b
z = b -> c -> a -> b
f b
z c
x a
y
           in Day MultiArg EndpointMap b -> Captures b
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Day MultiArg EndpointMap b -> Captures b)
-> Day MultiArg EndpointMap b -> Captures b
forall a b. (a -> b) -> a -> b
$ MultiArg b
-> EndpointMap (b -> b)
-> (b -> (b -> b) -> b)
-> Day MultiArg EndpointMap b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day MultiArg b
a (Opt a -> EndpointMap (a -> b -> b) -> EndpointMap (b -> b)
forall a b. Opt a -> EndpointMap (a -> b) -> EndpointMap b
addEPMOpt Opt a
o (c -> a -> b -> b
f' (c -> a -> b -> b) -> EndpointMap c -> EndpointMap (a -> b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EndpointMap c
p)) b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
(&)
    ep' :: EndpointMap b
ep' = Opt a -> EndpointMap (a -> b) -> EndpointMap b
forall a b. Opt a -> EndpointMap (a -> b) -> EndpointMap b
addEPMOpt Opt a
o EndpointMap (a -> b)
ep

infixr 4 ?:>

addEndpointOpt :: Opt a -> Endpoint (a -> b) -> Endpoint b
addEndpointOpt :: forall a b. Opt a -> Endpoint (a -> b) -> Endpoint b
addEndpointOpt Opt a
o (Endpoint (Day Ap Opt b
eo Parser c
eb b -> c -> a -> b
ef)) =
  Day (Ap Opt) Parser b -> Endpoint b
forall a. Day (Ap Opt) Parser a -> Endpoint a
Endpoint (Ap Opt (a, b)
-> Parser c -> ((a, b) -> c -> b) -> Day (Ap Opt) Parser b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day ((,) (a -> b -> (a, b)) -> Ap Opt a -> Ap Opt (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Opt a -> Ap Opt a
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Ap f
inject Opt a
o Ap Opt (b -> (a, b)) -> Ap Opt b -> Ap Opt (a, b)
forall a b. Ap Opt (a -> b) -> Ap Opt a -> Ap Opt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ap Opt b
eo) Parser c
eb (((a, b) -> c -> b) -> Day (Ap Opt) Parser b)
-> ((a, b) -> c -> b) -> Day (Ap Opt) Parser b
forall a b. (a -> b) -> a -> b
$ \(a
x, b
y) c
z -> b -> c -> a -> b
ef b
y c
z a
x)

addEPMOpt :: Opt a -> EndpointMap (a -> b) -> EndpointMap b
addEPMOpt :: forall a b. Opt a -> EndpointMap (a -> b) -> EndpointMap b
addEPMOpt Opt a
o (EPM Map Method (Endpoint (a -> b))
e Maybe (Endpoint (Method -> a -> b))
r) = Map Method (Endpoint b)
-> Maybe (Endpoint (Method -> b)) -> EndpointMap b
forall a.
Map Method (Endpoint a)
-> Maybe (Endpoint (Method -> a)) -> EndpointMap a
EPM Map Method (Endpoint b)
e' Maybe (Endpoint (Method -> b))
r'
  where
    e' :: Map Method (Endpoint b)
e' = Opt a -> Endpoint (a -> b) -> Endpoint b
forall a b. Opt a -> Endpoint (a -> b) -> Endpoint b
addEndpointOpt Opt a
o (Endpoint (a -> b) -> Endpoint b)
-> Map Method (Endpoint (a -> b)) -> Map Method (Endpoint b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Method (Endpoint (a -> b))
e
    r' :: Maybe (Endpoint (Method -> b))
r' = Opt a -> Endpoint (a -> Method -> b) -> Endpoint (Method -> b)
forall a b. Opt a -> Endpoint (a -> b) -> Endpoint b
addEndpointOpt Opt a
o (Endpoint (a -> Method -> b) -> Endpoint (Method -> b))
-> (Endpoint (Method -> a -> b) -> Endpoint (a -> Method -> b))
-> Endpoint (Method -> a -> b)
-> Endpoint (Method -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Method -> a -> b) -> a -> Method -> b)
-> Endpoint (Method -> a -> b) -> Endpoint (a -> Method -> b)
forall a b. (a -> b) -> Endpoint a -> Endpoint b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Method -> a -> b) -> a -> Method -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Endpoint (Method -> a -> b) -> Endpoint (Method -> b))
-> Maybe (Endpoint (Method -> a -> b))
-> Maybe (Endpoint (Method -> b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Endpoint (Method -> a -> b))
r

-- | Add notes to the beginning of a documentation level.
note :: [String] -> PStruct a -> PStruct a
note :: forall a. [String] -> PStruct a -> PStruct a
note [String]
ns (PStruct [String]
ms Map String (PStruct a)
cs Maybe (Captures a)
c EndpointMap a
ep) = [String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
forall a.
[String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
PStruct ([String]
ns [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ms) Map String (PStruct a)
cs Maybe (Captures a)
c EndpointMap a
ep

infixr 4 `note`

-- | Add a single argument praser.
(#:>) :: Arg a -> PStruct (a -> b) -> PStruct b
Arg a
a #:> :: forall a b. Arg a -> PStruct (a -> b) -> PStruct b
#:> PStruct (a -> b)
p = PStruct b
forall a. Monoid a => a
mempty {psCaptures = Just (L1 (Day a p (&)))}

infixr 4 #:>

-- | Add a repeating argument parser.
(##:>) :: Arg a -> PStruct ([a] -> b) -> PStruct b
Arg a
a ##:> :: forall a b. Arg a -> PStruct ([a] -> b) -> PStruct b
##:> PStruct ([a] -> b)
p =
  PStruct b
forall a. Monoid a => a
mempty
    { psCaptures = Just (R1 (Day (MultiArg a) (psEndpoints p) (&)))
    }

infixr 4 ##:>

-- | Add a request body to all endpoints.
--
-- If done more than once per endpoint, it runs *both* parsers; however,
-- we can only send one request body, so this is undefined behavior as
-- a client.
(%:>) :: Parser a -> PStruct (a -> b) -> PStruct b
Parser a
b %:> :: forall a b. Parser a -> PStruct (a -> b) -> PStruct b
%:> PStruct [String]
ns Map String (PStruct (a -> b))
cs Maybe (Captures (a -> b))
c EndpointMap (a -> b)
ep = [String]
-> Map String (PStruct b)
-> Maybe (Captures b)
-> EndpointMap b
-> PStruct b
forall a.
[String]
-> Map String (PStruct a)
-> Maybe (Captures a)
-> EndpointMap a
-> PStruct a
PStruct [String]
ns Map String (PStruct b)
cs' Maybe (Captures b)
c' EndpointMap b
ep'
  where
    cs' :: Map String (PStruct b)
cs' = (Parser a
b Parser a -> PStruct (a -> b) -> PStruct b
forall a b. Parser a -> PStruct (a -> b) -> PStruct b
%:>) (PStruct (a -> b) -> PStruct b)
-> Map String (PStruct (a -> b)) -> Map String (PStruct b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String (PStruct (a -> b))
cs
    c' :: Maybe (Captures b)
c' =
      Maybe (Captures (a -> b))
c Maybe (Captures (a -> b))
-> (Captures (a -> b) -> Captures b) -> Maybe (Captures b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        L1 (Day Arg b
a PStruct c
p b -> c -> a -> b
f) ->
          let f' :: c -> a -> b -> b
f' c
x a
y b
z = b -> c -> a -> b
f b
z c
x a
y
           in Day Arg PStruct b -> Captures b
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Day Arg PStruct b -> Captures b)
-> Day Arg PStruct b -> Captures b
forall a b. (a -> b) -> a -> b
$ Arg b
-> PStruct (b -> b) -> (b -> (b -> b) -> b) -> Day Arg PStruct b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day Arg b
a (Parser a
b Parser a -> PStruct (a -> b -> b) -> PStruct (b -> b)
forall a b. Parser a -> PStruct (a -> b) -> PStruct b
%:> (c -> a -> b -> b
f' (c -> a -> b -> b) -> PStruct c -> PStruct (a -> b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PStruct c
p)) b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
(&)
        R1 (Day MultiArg b
a EndpointMap c
p b -> c -> a -> b
f) ->
          let f' :: c -> a -> b -> b
f' c
x a
y b
z = b -> c -> a -> b
f b
z c
x a
y
           in Day MultiArg EndpointMap b -> Captures b
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Day MultiArg EndpointMap b -> Captures b)
-> Day MultiArg EndpointMap b -> Captures b
forall a b. (a -> b) -> a -> b
$ MultiArg b
-> EndpointMap (b -> b)
-> (b -> (b -> b) -> b)
-> Day MultiArg EndpointMap b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day MultiArg b
a (Parser a -> EndpointMap (a -> b -> b) -> EndpointMap (b -> b)
forall a b. Parser a -> EndpointMap (a -> b) -> EndpointMap b
addEPMBody Parser a
b (c -> a -> b -> b
f' (c -> a -> b -> b) -> EndpointMap c -> EndpointMap (a -> b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EndpointMap c
p)) b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
(&)
    ep' :: EndpointMap b
ep' = Parser a -> EndpointMap (a -> b) -> EndpointMap b
forall a b. Parser a -> EndpointMap (a -> b) -> EndpointMap b
addEPMBody Parser a
b EndpointMap (a -> b)
ep

infixr 4 %:>

addEndpointBody :: Parser a -> Endpoint (a -> b) -> Endpoint b
addEndpointBody :: forall a b. Parser a -> Endpoint (a -> b) -> Endpoint b
addEndpointBody Parser a
b (Endpoint Day (Ap Opt) Parser (a -> b)
d) =
  Day (Ap Opt) Parser b -> Endpoint b
forall a. Day (Ap Opt) Parser a -> Endpoint a
Endpoint (Parser a -> Day (Ap Opt) Parser a
Parser ~> Day (Ap Opt) Parser
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *) (g :: * -> *).
MonoidIn t i f =>
g ~> t f g
inR Parser a
b Day (Ap Opt) Parser a
-> Day (Ap Opt) Parser (a -> b) -> Day (Ap Opt) Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Day (Ap Opt) Parser (a -> b)
d)

addEPMBody :: Parser a -> EndpointMap (a -> b) -> EndpointMap b
addEPMBody :: forall a b. Parser a -> EndpointMap (a -> b) -> EndpointMap b
addEPMBody Parser a
b (EPM Map Method (Endpoint (a -> b))
e Maybe (Endpoint (Method -> a -> b))
r) = Map Method (Endpoint b)
-> Maybe (Endpoint (Method -> b)) -> EndpointMap b
forall a.
Map Method (Endpoint a)
-> Maybe (Endpoint (Method -> a)) -> EndpointMap a
EPM Map Method (Endpoint b)
e' Maybe (Endpoint (Method -> b))
r'
  where
    e' :: Map Method (Endpoint b)
e' = Parser a -> Endpoint (a -> b) -> Endpoint b
forall a b. Parser a -> Endpoint (a -> b) -> Endpoint b
addEndpointBody Parser a
b (Endpoint (a -> b) -> Endpoint b)
-> Map Method (Endpoint (a -> b)) -> Map Method (Endpoint b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Method (Endpoint (a -> b))
e
    r' :: Maybe (Endpoint (Method -> b))
r' = Parser a -> Endpoint (a -> Method -> b) -> Endpoint (Method -> b)
forall a b. Parser a -> Endpoint (a -> b) -> Endpoint b
addEndpointBody Parser a
b (Endpoint (a -> Method -> b) -> Endpoint (Method -> b))
-> (Endpoint (Method -> a -> b) -> Endpoint (a -> Method -> b))
-> Endpoint (Method -> a -> b)
-> Endpoint (Method -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Method -> a -> b) -> a -> Method -> b)
-> Endpoint (Method -> a -> b) -> Endpoint (a -> Method -> b)
forall a b. (a -> b) -> Endpoint a -> Endpoint b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Method -> a -> b) -> a -> Method -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Endpoint (Method -> a -> b) -> Endpoint (Method -> b))
-> Maybe (Endpoint (Method -> a -> b))
-> Maybe (Endpoint (Method -> b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Endpoint (Method -> a -> b))
r

-- | Create an endpoint action.
endpoint :: HTTP.Method -> a -> PStruct a
endpoint :: forall a. Method -> a -> PStruct a
endpoint Method
m a
x =
  PStruct a
forall a. Monoid a => a
mempty
    { psEndpoints = EPM (M.singleton m (Endpoint (pure x))) Nothing
    }

-- | Create a raw endpoint.
rawEndpoint :: (HTTP.Method -> a) -> PStruct a
rawEndpoint :: forall a. (Method -> a) -> PStruct a
rawEndpoint Method -> a
f =
  PStruct a
forall a. Monoid a => a
mempty
    { psEndpoints = EPM M.empty (Just (Endpoint (pure f)))
    }

-- | Helper to lift a 'ReadM' into something that can be used with 'optRead'.
orRequired :: ReadM a -> Coyoneda OptRead a
orRequired :: forall a. ReadM a -> Coyoneda OptRead a
orRequired = OptRead a -> Coyoneda OptRead a
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Coyoneda f
inject (OptRead a -> Coyoneda OptRead a)
-> (ReadM a -> OptRead a) -> ReadM a -> Coyoneda OptRead a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM a -> OptRead a
forall a. ReadM a -> OptRead a
ORRequired

-- | Helper to lift an optional 'ReadM' into something that can be used
-- with 'optRead'.
orOptional :: ReadM a -> Coyoneda OptRead (Maybe a)
orOptional :: forall a. ReadM a -> Coyoneda OptRead (Maybe a)
orOptional = OptRead (Maybe a) -> Coyoneda OptRead (Maybe a)
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Coyoneda f
inject (OptRead (Maybe a) -> Coyoneda OptRead (Maybe a))
-> (ReadM a -> OptRead (Maybe a))
-> ReadM a
-> Coyoneda OptRead (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM a -> OptRead (Maybe a)
forall a. ReadM a -> OptRead (Maybe a)
OROptional

-- | An 'optRead' that is on-or-off.
orSwitch :: Coyoneda OptRead Bool
orSwitch :: Coyoneda OptRead Bool
orSwitch = OptRead Bool -> Coyoneda OptRead Bool
forall {k} (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
forall (f :: * -> *). f ~> Coyoneda f
inject OptRead Bool
ORSwitch