155 lines
5.0 KiB
Haskell
155 lines
5.0 KiB
Haskell
{-# 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 _ f g mx =
|
|
case (sbool :: SBool (FoldRequired mods), mx) of
|
|
(STrue, x) -> f x
|
|
(SFalse, x) -> g 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 _ errReq errSt mex =
|
|
case (sbool :: SBool (FoldRequired mods), mex) of
|
|
(STrue, Nothing) -> errReq
|
|
(SFalse, Nothing) -> return Nothing
|
|
(STrue, Just ex) -> either errSt return ex
|
|
(SFalse, Just ex) -> either errSt (return . Just) 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 _ errReq errSt mex =
|
|
case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of
|
|
(STrue, Nothing, _) -> errReq
|
|
(SFalse, Nothing, _) -> return Nothing
|
|
(STrue, Just ex, STrue) -> return ex
|
|
(STrue, Just ex, SFalse) -> either errSt return ex
|
|
(SFalse, Just ex, STrue) -> return (Just ex)
|
|
(SFalse, Just ex, SFalse) -> either errSt (return . Just) ex
|
|
|
|
-- $setup
|
|
-- >>> import Servant.API
|