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

{- |
Module      : Servant.API.Routes.Internal.Response
Copyright   : (c) Frederick Pringle, 2025
License     : BSD-3-Clause
Maintainer  : freddyjepringle@gmail.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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, Response -> Response -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq, Eq 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
min :: Response -> Response -> Response
$cmin :: Response -> Response -> Response
max :: Response -> Response -> Response
$cmax :: Response -> Response -> Response
>= :: Response -> Response -> Bool
$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
compare :: Response -> Response -> Ordering
$ccompare :: Response -> Response -> Ordering
Ord)

makeLenses ''Response

instance ToJSON Response where
  toJSON :: Response -> Value
toJSON Response {TypeRep
Set HeaderRep
_responseHeaders :: Set HeaderRep
_responseType :: TypeRep
_responseHeaders :: Response -> Set HeaderRep
_responseType :: Response -> TypeRep
..} =
    [Pair] -> Value
object
      [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TypeRep -> Value
typeRepToJSON TypeRep
_responseType
      , Key
"headers" forall kv v. (KeyValue 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) 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
      forall a b. a -> (a -> b) -> b
& Lens' Response (Set HeaderRep)
responseHeaders forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ 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 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Responses] -> ShowS
$cshowList :: [Responses] -> ShowS
show :: Responses -> String
$cshow :: Responses -> String
showsPrec :: Int -> Responses -> ShowS
$cshowsPrec :: Int -> Responses -> ShowS
Show) via Some Response

makeLenses ''Responses

instance Eq Responses where
  == :: Responses -> Responses -> Bool
(==) = forall a. Eq a => ([a] -> [a] -> Bool) -> Some a -> Some a -> Bool
eqSome (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub)) 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 (forall a.
(a -> [a] -> [a])
-> ([a] -> a -> [a]) -> Some a -> Some a -> Some a
appendSome (:) (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 forall a. Some a
S.None

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