{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK not-home #-}

{- |
Module      : Servant.API.Routes.Internal.Response
Copyright   : (c) Frederick Pringle, 2025
License     : BSD-3-Clause
Maintainer  : frederick.pringle@fpringle.com

Internal module, subject to change.
-}
module Servant.API.Routes.Internal.Response
  ( Responses (..)
  , unResponses
  , Response (..)
  , responseType
  , responseHeaders
  , HasResponse (..)
  , AllHasResponse (..)
  )
where

import Data.Aeson
import Data.Function (on)
import Data.Kind (Type)
import Data.List (nub, sort)
import qualified Data.Set as Set
import Data.Typeable
import Lens.Micro
import Lens.Micro.TH
import Servant.API hiding (getResponse)
import "this" Servant.API.Routes.Internal.Header
import "this" Servant.API.Routes.Internal.Some as S
import "this" Servant.API.Routes.Utils

{- | A representation of /one/ possible response that a Servant endpoint
can return.

Currently, the only situation in which multiple 'Response's can be returned
is using the 'UVerb' combinator. This bundles response /types/ together with
response 'Servant.API.Header.Header's, so we do the same here.
-}
data Response = Response
  { Response -> TypeRep
_responseType :: TypeRep
  , Response -> Set HeaderRep
_responseHeaders :: Set.Set HeaderRep
  }
  deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Response -> ShowS
showsPrec :: Int -> Response -> ShowS
$cshow :: Response -> String
show :: Response -> String
$cshowList :: [Response] -> ShowS
showList :: [Response] -> ShowS
Show, Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
/= :: Response -> Response -> Bool
Eq, Eq Response
Eq Response =>
(Response -> Response -> Ordering)
-> (Response -> Response -> Bool)
-> (Response -> Response -> Bool)
-> (Response -> Response -> Bool)
-> (Response -> Response -> Bool)
-> (Response -> Response -> Response)
-> (Response -> Response -> Response)
-> Ord Response
Response -> Response -> Bool
Response -> Response -> Ordering
Response -> Response -> Response
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Response -> Response -> Ordering
compare :: Response -> Response -> Ordering
$c< :: Response -> Response -> Bool
< :: Response -> Response -> Bool
$c<= :: Response -> Response -> Bool
<= :: Response -> Response -> Bool
$c> :: Response -> Response -> Bool
> :: Response -> Response -> Bool
$c>= :: Response -> Response -> Bool
>= :: Response -> Response -> Bool
$cmax :: Response -> Response -> Response
max :: Response -> Response -> Response
$cmin :: Response -> Response -> Response
min :: Response -> Response -> Response
Ord)

makeLenses ''Response

instance ToJSON Response where
  toJSON :: Response -> Value
toJSON Response {TypeRep
Set HeaderRep
_responseType :: Response -> TypeRep
_responseHeaders :: Response -> Set HeaderRep
_responseType :: TypeRep
_responseHeaders :: Set HeaderRep
..} =
    [Pair] -> Value
object
      [ Key
"type" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TypeRep -> Value
typeRepToJSON TypeRep
_responseType
      , Key
"headers" Key -> Set HeaderRep -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Set HeaderRep
_responseHeaders
      ]

{- | Get a term-level response from a type-level argument. This encodes the argument(s)
of a 'Verb' or 'UVerb'.

Similar to 'Typeable', but also get the response 'Servant.API.Header.Header's.
-}
class HasResponse a where
  getResponse :: Response

instance {-# OVERLAPPABLE #-} (Typeable a) => HasResponse a where
  getResponse :: Response
getResponse = TypeRep -> Set HeaderRep -> Response
Response (forall a. Typeable a => TypeRep
typeRepOf @a) Set HeaderRep
forall a. Monoid a => a
mempty

instance {-# OVERLAPPING #-} (HasResponse a, GetHeaderReps hs) => HasResponse (Headers hs a) where
  getResponse :: Response
getResponse =
    forall a. HasResponse a => Response
getResponse @a
      Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Set HeaderRep -> Identity (Set HeaderRep))
-> Response -> Identity Response
Lens' Response (Set HeaderRep)
responseHeaders ((Set HeaderRep -> Identity (Set HeaderRep))
 -> Response -> Identity Response)
-> Set HeaderRep -> Response -> Response
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [HeaderRep] -> Set HeaderRep
forall a. Ord a => [a] -> Set a
Set.fromList (forall (hs :: [*]). GetHeaderReps hs => [HeaderRep]
getHeaderReps @hs)

{- | Witness that all members of a type-level list are instances of 'HasResponse'.

This class does 2 things:

- It lets us get a term-level list of 'Response's from a type-level list of types, all of
  which have 'HasResponse' instances.
- More impressively, its instances enforce that 'getResponses' will only type-check for type-level
  lists of length 2 or more. This is because 'AllHasResponse' will only ever be used by
  'Servant.API.Routes.Response.oneOfResponses', which is the only way to construct a
  'Many' @'Response' and thus lets us enforce the invariant that its list arguments will always
  have more than 1 element. This lets us make sure that there's only ever one way to represent a list of
  'Response's using 'Responses'.

  Of course, someone might import this Internal module and define a @'HasResponse' a => 'AllHasResponse' '[a]@
  instance. Don't do that.
-}
class AllHasResponse (as :: [Type]) where
  getResponses :: [Response]

instance (HasResponse a, HasResponse b) => AllHasResponse '[a, b] where
  getResponses :: [Response]
getResponses = [forall a. HasResponse a => Response
getResponse @a, forall a. HasResponse a => Response
getResponse @b]

instance (HasResponse a, AllHasResponse (b ': c ': as)) => AllHasResponse (a ': b ': c ': as) where
  getResponses :: [Response]
getResponses = forall a. HasResponse a => Response
getResponse @a Response -> [Response] -> [Response]
forall a. a -> [a] -> [a]
: forall (as :: [*]). AllHasResponse as => [Response]
getResponses @(b ': c ': as)

{- | A representation of the response(s) that a Servant endpoint can return.

Under the hood, 'Responses' is a @'Some' 'Response'@.
This allows for the possibility that an endpoint might return one of several
responses, via 'UVerb'.

Note that a 'Response' consists of a return body type, /as well as/ the return headers.
-}
newtype Responses = Responses {Responses -> Some Response
_unResponses :: Some Response}
  deriving (Int -> Responses -> ShowS
[Responses] -> ShowS
Responses -> String
(Int -> Responses -> ShowS)
-> (Responses -> String)
-> ([Responses] -> ShowS)
-> Show Responses
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Responses -> ShowS
showsPrec :: Int -> Responses -> ShowS
$cshow :: Responses -> String
show :: Responses -> String
$cshowList :: [Responses] -> ShowS
showList :: [Responses] -> ShowS
Show) via Some Response

makeLenses ''Responses

instance Eq Responses where
  == :: Responses -> Responses -> Bool
(==) = ([Response] -> [Response] -> Bool)
-> Some Response -> Some Response -> Bool
forall a. Eq a => ([a] -> [a] -> Bool) -> Some a -> Some a -> Bool
eqSome ([Response] -> [Response] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Response] -> [Response] -> Bool)
-> ([Response] -> [Response]) -> [Response] -> [Response] -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Response] -> [Response]
forall a. Ord a => [a] -> [a]
sort ([Response] -> [Response])
-> ([Response] -> [Response]) -> [Response] -> [Response]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Response] -> [Response]
forall a. Eq a => [a] -> [a]
nub)) (Some Response -> Some Response -> Bool)
-> (Responses -> Some Response) -> Responses -> Responses -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Responses -> Some Response
_unResponses

instance Semigroup Responses where
  Responses Some Response
b1 <> :: Responses -> Responses -> Responses
<> Responses Some Response
b2 = Some Response -> Responses
Responses ((Response -> [Response] -> [Response])
-> ([Response] -> Response -> [Response])
-> Some Response
-> Some Response
-> Some Response
forall a.
(a -> [a] -> [a])
-> ([a] -> a -> [a]) -> Some a -> Some a -> Some a
appendSome (:) ((Response -> [Response] -> [Response])
-> [Response] -> Response -> [Response]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) Some Response
b1 Some Response
b2)

instance Monoid Responses where
  mempty :: Responses
mempty = Some Response -> Responses
Responses Some Response
forall a. Some a
S.None

instance ToJSON Responses where
  toJSON :: Responses -> Value
toJSON = (Response -> Value) -> Text -> Some Response -> Value
forall a. (a -> Value) -> Text -> Some a -> Value
someToJSONAs Response -> Value
forall a. ToJSON a => a -> Value
toJSON Text
"one_of" (Some Response -> Value)
-> (Responses -> Some Response) -> Responses -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Responses -> Some Response
_unResponses