    {-# LANGUAGE DataKinds           #-}
    {-# LANGUAGE FlexibleContexts    #-}

    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeFamilies        #-}
    {-# LANGUAGE TypeOperators       #-}
    {-# OPTIONS_GHC -Wno-redundant-constraints #-}
    module Servant.API.Modifiers (
        -- * Required / optional argument
        Required, Optional,
        FoldRequired, FoldRequired',
        -- * Lenient / strict parsing
        Lenient, Strict,
        FoldLenient, FoldLenient',
        -- * Utilities
        RequiredArgument,
        foldRequiredArgument,
        unfoldRequiredArgument,
        RequestArgument,
        unfoldRequestArgument,
        ) where

    import           Data.Kind
                     (Type)
    import           Data.Proxy
                     (Proxy (..))
    import           Data.Singletons.Bool
                     (SBool (..), SBoolI (..))
    import           Data.Text
                     (Text)
    import           Data.Type.Bool
                     (If)

    -- | Required argument. Not wrapped.
    data Required

    -- | Optional argument. Wrapped in 'Maybe'.
    data Optional

    -- | Fold modifier list to decide whether argument is required.
    --
    -- >>> :kind! FoldRequired '[Required, Description "something"]
    -- FoldRequired '[Required, Description "something"] :: Bool
    -- = 'True
    --
    -- >>> :kind! FoldRequired '[Required, Optional]
    -- FoldRequired '[Required, Optional] :: Bool
    -- = 'False
    --
    -- >>> :kind! FoldRequired '[]
    -- FoldRequired '[] :: Bool
    -- = 'False
    --
    type FoldRequired mods = FoldRequired' 'False mods

    -- | Implementation of 'FoldRequired'.
    type family FoldRequired' (acc :: Bool) (mods :: [Type]) :: Bool where
        FoldRequired' acc '[]                = acc
        FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods
        FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods
        FoldRequired' acc (mod      ': mods) = FoldRequired' acc mods

    -- | Leniently parsed argument, i.e. parsing never fail. Wrapped in @'Either' 'Text'@.
    data Lenient

    -- | Strictly parsed argument. Not wrapped.
    data Strict

    -- | Fold modifier list to decide whether argument should be parsed strictly or leniently.
    --
    -- >>> :kind! FoldLenient '[]
    -- FoldLenient '[] :: Bool
    -- = 'False
    --
    type FoldLenient mods = FoldLenient' 'False mods

    -- | Implementation of 'FoldLenient'.
    type family FoldLenient' (acc :: Bool) (mods ::  [Type]) :: Bool where
        FoldLenient' acc '[]               = acc
        FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods
        FoldLenient' acc (Strict  ': mods) = FoldLenient' 'False mods
        FoldLenient' acc (mod     ': mods) = FoldLenient' acc mods

    -- | Helper type alias.
    --
    -- * 'Required' ↦ @a@
    --
    -- * 'Optional' ↦ @'Maybe' a@
    --
    type RequiredArgument mods a = If (FoldRequired mods) a (Maybe a)

    -- | Fold a 'RequiredAgument' into a value
    foldRequiredArgument
        :: forall mods a r. (SBoolI (FoldRequired mods))
        => Proxy mods
        -> (a -> r)        -- ^ 'Required'
        -> (Maybe a -> r)  -- ^ 'Optional'
        -> RequiredArgument mods a
        -> r
    foldRequiredArgument :: forall (mods :: [Type]) a r.
    SBoolI (FoldRequired mods) =>
    Proxy mods
    -> (a -> r) -> (Maybe a -> r) -> RequiredArgument mods a -> r
    foldRequiredArgument Proxy mods
    _ a -> r
    f Maybe a -> r
    g RequiredArgument mods a
    mx =
        case (SBool (FoldRequired mods)
    forall (b :: Bool). SBoolI b => SBool b
    sbool :: SBool (FoldRequired mods), RequiredArgument mods a
    mx) of
            (SBool (FoldRequired mods)
    STrue, RequiredArgument mods a
    x)  -> a -> r
    f a
    RequiredArgument mods a
    x
            (SBool (FoldRequired mods)
    SFalse, RequiredArgument mods a
    x) -> Maybe a -> r
    g Maybe a
    RequiredArgument mods a
    x

    -- | Unfold a value into a 'RequiredArgument'.
    unfoldRequiredArgument
        :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))
        => Proxy mods
        -> m (RequiredArgument mods a)            -- ^ error when argument is required
        -> (Text -> m (RequiredArgument mods a))  -- ^ error when argument is strictly parsed
        -> Maybe (Either Text a)                  -- ^ value
        -> m (RequiredArgument mods a)
    unfoldRequiredArgument :: forall (mods :: [Type]) (m :: Type -> Type) a.
    (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
    Proxy mods
    -> m (RequiredArgument mods a)
    -> (Text -> m (RequiredArgument mods a))
    -> Maybe (Either Text a)
    -> m (RequiredArgument mods a)
    unfoldRequiredArgument Proxy mods
    _ m (RequiredArgument mods a)
    errReq Text -> m (RequiredArgument mods a)
    errSt Maybe (Either Text a)
    mex =
        case (SBool (FoldRequired mods)
    forall (b :: Bool). SBoolI b => SBool b
    sbool :: SBool (FoldRequired mods), Maybe (Either Text a)
    mex) of
            (SBool (FoldRequired mods)
    STrue, Maybe (Either Text a)
    Nothing)  -> m (RequiredArgument mods a)
    errReq
            (SBool (FoldRequired mods)
    SFalse, Maybe (Either Text a)
    Nothing) -> Maybe a -> m (Maybe a)
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing
            (SBool (FoldRequired mods)
    STrue, Just Either Text a
    ex)  -> (Text -> m a) -> (a -> m a) -> Either Text a -> m a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Text -> m a
    Text -> m (RequiredArgument mods a)
    errSt a -> m a
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Either Text a
    ex
            (SBool (FoldRequired mods)
    SFalse, Just Either Text a
    ex) -> (Text -> m (Maybe a))
    -> (a -> m (Maybe a)) -> Either Text a -> m (Maybe a)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Text -> m (Maybe a)
    Text -> m (RequiredArgument mods a)
    errSt (Maybe a -> m (Maybe a)
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Maybe a
    forall a. a -> Maybe a
    Just) Either Text a
    ex

    -- | Helper type alias.
    --
    -- By default argument is 'Optional' and 'Strict'.
    --
    -- * 'Required', 'Strict' ↦ @a@
    --
    -- * 'Required', 'Lenient' ↦ @'Either' 'Text' a@
    --
    -- * 'Optional', 'Strict' ↦ @'Maybe' a@
    --
    -- * 'Optional', 'Lenient' ↦ @'Maybe' ('Either' 'Text' a)@
    --
    type RequestArgument mods a =
        If (FoldRequired mods)
           (If (FoldLenient mods) (Either Text a) a)
           (Maybe (If (FoldLenient mods) (Either Text a) a))

    -- | Unfold a value into a 'RequestArgument'.
    unfoldRequestArgument
        :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))
        => Proxy mods
        -> m (RequestArgument mods a)            -- ^ error when argument is required
        -> (Text -> m (RequestArgument mods a))  -- ^ error when argument is strictly parsed
        -> Maybe (Either Text a)                 -- ^ value
        -> m (RequestArgument mods a)
    unfoldRequestArgument :: forall (mods :: [Type]) (m :: Type -> Type) a.
    (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) =>
    Proxy mods
    -> m (RequestArgument mods a)
    -> (Text -> m (RequestArgument mods a))
    -> Maybe (Either Text a)
    -> m (RequestArgument mods a)
    unfoldRequestArgument Proxy mods
    _ m (RequestArgument mods a)
    errReq Text -> m (RequestArgument mods a)
    errSt Maybe (Either Text a)
    mex =
        case (SBool (FoldRequired mods)
    forall (b :: Bool). SBoolI b => SBool b
    sbool :: SBool (FoldRequired mods), Maybe (Either Text a)
    mex, SBool (FoldLenient mods)
    forall (b :: Bool). SBoolI b => SBool b
    sbool :: SBool (FoldLenient mods)) of
            (SBool (FoldRequired mods)
    STrue,  Maybe (Either Text a)
    Nothing, SBool (FoldLenient mods)
    _)      -> m (RequestArgument mods a)
    errReq
            (SBool (FoldRequired mods)
    SFalse, Maybe (Either Text a)
    Nothing, SBool (FoldLenient mods)
    _)      -> Maybe (If (FoldLenient mods) (Either Text a) a)
    -> m (Maybe (If (FoldLenient mods) (Either Text a) a))
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Maybe (If (FoldLenient mods) (Either Text a) a)
    forall a. Maybe a
    Nothing
            (SBool (FoldRequired mods)
    STrue,  Just Either Text a
    ex, SBool (FoldLenient mods)
    STrue)  -> Either Text a -> m (Either Text a)
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Either Text a
    ex
            (SBool (FoldRequired mods)
    STrue,  Just Either Text a
    ex, SBool (FoldLenient mods)
    SFalse) -> (Text -> m a) -> (a -> m a) -> Either Text a -> m a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Text -> m a
    Text -> m (RequestArgument mods a)
    errSt a -> m a
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Either Text a
    ex
            (SBool (FoldRequired mods)
    SFalse, Just Either Text a
    ex, SBool (FoldLenient mods)
    STrue)  -> Maybe (Either Text a) -> m (Maybe (Either Text a))
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Either Text a -> Maybe (Either Text a)
    forall a. a -> Maybe a
    Just Either Text a
    ex)
            (SBool (FoldRequired mods)
    SFalse, Just Either Text a
    ex, SBool (FoldLenient mods)
    SFalse) -> (Text -> m (Maybe a))
    -> (a -> m (Maybe a)) -> Either Text a -> m (Maybe a)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Text -> m (Maybe a)
    Text -> m (RequestArgument mods a)
    errSt (Maybe a -> m (Maybe a)
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Maybe a
    forall a. a -> Maybe a
    Just) Either Text a
    ex

    -- $setup
    -- >>> import Servant.API