{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
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.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 :: [*]) :: 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 ::  [*]) :: 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 :: 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' 'False mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldRequired mods), RequiredArgument mods a
mx) of
        (SBool (FoldRequired' 'False mods)
STrue, RequiredArgument mods a
x)  -> a -> r
f a
RequiredArgument mods a
x
        (SBool (FoldRequired' 'False 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 :: 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' 'False mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldRequired mods), Maybe (Either Text a)
mex) of
        (SBool (FoldRequired' 'False mods)
STrue, Maybe (Either Text a)
Nothing)  -> m (RequiredArgument mods a)
errReq
        (SBool (FoldRequired' 'False mods)
SFalse, Maybe (Either Text a)
Nothing) -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        (SBool (FoldRequired' 'False 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 (m :: * -> *) a. Monad m => a -> m a
return Either Text a
ex
        (SBool (FoldRequired' 'False 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 (m :: * -> *) 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 :: 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' 'False mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldRequired mods), Maybe (Either Text a)
mex, SBool (FoldLenient' 'False mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldLenient mods)) of
        (SBool (FoldRequired' 'False mods)
STrue,  Maybe (Either Text a)
Nothing, SBool (FoldLenient' 'False mods)
_)      -> m (RequestArgument mods a)
errReq
        (SBool (FoldRequired' 'False mods)
SFalse, Maybe (Either Text a)
Nothing, SBool (FoldLenient' 'False mods)
_)      -> Maybe (If (FoldLenient' 'False mods) (Either Text a) a)
-> m (Maybe (If (FoldLenient' 'False mods) (Either Text a) a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (If (FoldLenient' 'False mods) (Either Text a) a)
forall a. Maybe a
Nothing
        (SBool (FoldRequired' 'False mods)
STrue,  Just Either Text a
ex, SBool (FoldLenient' 'False mods)
STrue)  -> Either Text a -> m (Either Text a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Text a
ex
        (SBool (FoldRequired' 'False mods)
STrue,  Just Either Text a
ex, SBool (FoldLenient' 'False 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 (m :: * -> *) a. Monad m => a -> m a
return Either Text a
ex
        (SBool (FoldRequired' 'False mods)
SFalse, Just Either Text a
ex, SBool (FoldLenient' 'False mods)
STrue)  -> Maybe (Either Text a) -> m (Maybe (Either Text a))
forall (m :: * -> *) 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' 'False mods)
SFalse, Just Either Text a
ex, SBool (FoldLenient' 'False 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 (m :: * -> *) 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