    {-# LANGUAGE DataKinds     #-}
    {-# LANGUAGE PolyKinds     #-}
    {-# LANGUAGE RankNTypes    #-}
    {-# LANGUAGE TypeOperators #-}

    module Servant.Server.Internal.ErrorFormatter
      ( ErrorFormatters(..)
      , ErrorFormatter
      , NotFoundErrorFormatter

      , DefaultErrorFormatters
      , defaultErrorFormatters

      , MkContextWithErrorFormatter
      , mkContextWithErrorFormatter
      ) where

    import           Data.Kind (Type)
    import           Data.Typeable
    import           Network.Wai.Internal (Request)
    import qualified Data.ByteString.Lazy.Char8 as BSL8

    import           Servant.API
                     (Capture, ReqBody)
    import           Servant.Server.Internal.Context
    import           Servant.Server.Internal.ServerError

    -- | 'Context' that contains default error formatters.
    type DefaultErrorFormatters = '[ErrorFormatters]

    -- | A collection of error formatters for different situations.
    --
    -- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.
    data ErrorFormatters = ErrorFormatters
      { -- | Format error from parsing the request body.
        ErrorFormatters -> ErrorFormatter
    bodyParserErrorFormatter :: ErrorFormatter
        -- | Format error from parsing url parts or query parameters.
      , ErrorFormatters -> ErrorFormatter
    urlParseErrorFormatter :: ErrorFormatter
        -- | Format error from parsing request headers.
      , ErrorFormatters -> ErrorFormatter
    headerParseErrorFormatter :: ErrorFormatter
        -- | Format error for not found URLs.
      , ErrorFormatters -> NotFoundErrorFormatter
    notFoundErrorFormatter :: NotFoundErrorFormatter
      }

    -- | Default formatters will just return HTTP 400 status code with error
    -- message as response body.
    defaultErrorFormatters :: ErrorFormatters
    defaultErrorFormatters :: ErrorFormatters
    defaultErrorFormatters = ErrorFormatters
      { bodyParserErrorFormatter :: ErrorFormatter
    bodyParserErrorFormatter = ErrorFormatter
    err400Formatter
      , urlParseErrorFormatter :: ErrorFormatter
    urlParseErrorFormatter = ErrorFormatter
    err400Formatter
      , headerParseErrorFormatter :: ErrorFormatter
    headerParseErrorFormatter = ErrorFormatter
    err400Formatter
      , notFoundErrorFormatter :: NotFoundErrorFormatter
    notFoundErrorFormatter = ServerError -> NotFoundErrorFormatter
    forall a b. a -> b -> a
    const ServerError
    err404
      }

    -- | A custom formatter for errors produced by parsing combinators like
    -- 'ReqBody' or 'Capture'.
    --
    -- A 'TypeRep' argument described the concrete combinator that raised
    -- the error, allowing formatter to customize the message for different
    -- combinators.
    --
    -- A full 'Request' is also passed so that the formatter can react to @Accept@ header,
    -- for example.
    type ErrorFormatter = TypeRep -> Request -> String -> ServerError

    -- | This formatter does not get neither 'TypeRep' nor error message.
    type NotFoundErrorFormatter = Request -> ServerError

    type MkContextWithErrorFormatter (ctx :: [Type]) = ctx .++ DefaultErrorFormatters

    mkContextWithErrorFormatter :: forall (ctx :: [Type]). Context ctx -> Context (MkContextWithErrorFormatter ctx)
    mkContextWithErrorFormatter :: forall (ctx :: [Type]).
    Context ctx -> Context (MkContextWithErrorFormatter ctx)
    mkContextWithErrorFormatter Context ctx
    ctx = Context ctx
    ctx Context ctx
    -> Context '[ErrorFormatters]
    -> Context (ctx .++ '[ErrorFormatters])
    forall (l1 :: [Type]) (l2 :: [Type]).
    Context l1 -> Context l2 -> Context (l1 .++ l2)
    .++ (ErrorFormatters
    defaultErrorFormatters ErrorFormatters -> Context '[] -> Context '[ErrorFormatters]
    forall x (xs :: [Type]). x -> Context xs -> Context (x : xs)
    :. Context '[]
    EmptyContext)

    -- Internal

    err400Formatter :: ErrorFormatter
    err400Formatter :: ErrorFormatter
    err400Formatter TypeRep
    _ Request
    _ String
    e = ServerError
    err400 { errBody = BSL8.pack e }

    -- These definitions suppress "unused import" warning.
    -- The imorts are needed for Haddock to correctly link to them.
    _RB :: Proxy ReqBody
    _RB :: Proxy ReqBody
    _RB = Proxy ReqBody
    forall {k} (t :: k). Proxy t
    Proxy
    _C :: Proxy Capture
    _C :: Proxy Capture
    _C = Proxy Capture
    forall {k} (t :: k). Proxy t
    Proxy
    _CT :: Proxy Context
    _CT :: Proxy Context
    _CT = Proxy Context
    forall {k} (t :: k). Proxy t
    Proxy