{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# 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