{-# 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 _ 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 (FoldLenient mods), SBoolI (FoldRequired 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) -> pure Nothing
    (STrue, Just ex) -> either errSt pure ex
    (SFalse, Just ex) -> either errSt (pure . 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 (FoldLenient mods), SBoolI (FoldRequired 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, _) -> pure Nothing
    (STrue, Just ex, STrue) -> pure ex
    (STrue, Just ex, SFalse) -> either errSt pure ex
    (SFalse, Just ex, STrue) -> pure (Just ex)
    (SFalse, Just ex, SFalse) -> either errSt (pure . Just) ex

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