{-# OPTIONS_HADDOCK not-home #-}

{- |
Module      : Servant.API.Routes.Internal.Body
Copyright   : (c) Frederick Pringle, 2024
License     : BSD-3-Clause
Maintainer  : freddyjepringle@gmail.com

Internal module, subject to change.
-}
module Servant.API.Routes.Internal.Body
  ( Body (..)
  , bodyToList
  , listToBody
  , AllTypeable (..)
  )
where

import Data.Kind (Type)
import Data.List (nub, sort)
import Data.Typeable
import "this" Servant.API.Routes.Utils

{- | A more expressive sum-type than just a list. This can be useful in situations
where a body (request or response) may have several interpretations.

For example, the 'Servant.API.UVerb' combinator lets us represent an endpoint that may return one of
several types: hence the 'Servant.API.Routes._routeResponseType' field needs to be able to contain
several 'TypeRep's as a disjunction.

On the other hand, if multiple 'Servant.API.ReqBody''s are chained together with @:>@, the resulting
type's @HasServer@ instance would try to parse the request body as all of the relevant types. In this
case the 'Servant.API.Routes._routeRequestBody' field needs to be able to contain several 'TypeRep's
as a conjunction.
-}
data Body
  = NoBody
  | OneType TypeRep
  | -- | invariant: list needs to have length > 1
    ManyTypes [TypeRep] -- order not important
  deriving (Int -> Body -> ShowS
[Body] -> ShowS
Body -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Body] -> ShowS
$cshowList :: [Body] -> ShowS
show :: Body -> String
$cshow :: Body -> String
showsPrec :: Int -> Body -> ShowS
$cshowsPrec :: Int -> Body -> ShowS
Show)

-- | Convert a 'Body' to a list of 'TypeRep's. Inverse of 'listToBody'.
bodyToList :: Body -> [TypeRep]
bodyToList :: Body -> [TypeRep]
bodyToList = \case
  Body
NoBody -> []
  OneType TypeRep
tRep -> [TypeRep
tRep]
  ManyTypes [TypeRep]
tReps -> [TypeRep]
tReps

{- | Convert a list of 'TypeRep's to a 'Body'. Inverse of 'listToBody'.

This maintains the invariant that the argument of 'ManyTypes' has to be of length > 1.
-}
listToBody :: [TypeRep] -> Body
listToBody :: [TypeRep] -> Body
listToBody = \case
  [] -> Body
NoBody
  [TypeRep
tRep] -> TypeRep -> Body
OneType TypeRep
tRep
  [TypeRep]
tReps -> [TypeRep] -> Body
ManyTypes [TypeRep]
tReps

instance Eq Body where
  Body
NoBody == :: Body -> Body -> Bool
== Body
NoBody = Bool
True
  OneType TypeRep
t1 == OneType TypeRep
t2 = TypeRep
t1 forall a. Eq a => a -> a -> Bool
== TypeRep
t2
  ManyTypes [TypeRep]
ts1 == ManyTypes [TypeRep]
ts2 = forall a. Ord a => [a] -> [a]
sort (forall a. Eq a => [a] -> [a]
nub [TypeRep]
ts1) forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
sort (forall a. Eq a => [a] -> [a]
nub [TypeRep]
ts2)
  Body
_ == Body
_ = Bool
False

instance Semigroup Body where
  Body
NoBody <> :: Body -> Body -> Body
<> Body
x = Body
x
  Body
x <> Body
NoBody = Body
x
  OneType TypeRep
t1 <> OneType TypeRep
t2 = [TypeRep] -> Body
ManyTypes [TypeRep
t1, TypeRep
t2]
  OneType TypeRep
t <> ManyTypes [TypeRep]
ts = [TypeRep] -> Body
ManyTypes (TypeRep
t forall a. a -> [a] -> [a]
: [TypeRep]
ts)
  ManyTypes [TypeRep]
ts <> OneType TypeRep
t = [TypeRep] -> Body
ManyTypes (TypeRep
t forall a. a -> [a] -> [a]
: [TypeRep]
ts) -- order not important, more efficient
  ManyTypes [TypeRep]
ts1 <> ManyTypes [TypeRep]
ts2 = [TypeRep] -> Body
ManyTypes ([TypeRep]
ts1 forall a. Semigroup a => a -> a -> a
<> [TypeRep]
ts2)

instance Monoid Body where
  mempty :: Body
mempty = Body
NoBody

{- | This class does 2 things:

- It lets us get a term-level list of 'TypeRep's from a type-level list of types, all of
  which have 'Typeable' instances.
- More impressively, its instances enforce that 'typeReps' will only type-check for type-level
  lists of length 2 or more. This is because 'AllTypeable' will only ever be used by
  'Servant.API.Routes.Body.manyTypes' (and its aliases), which is the only way to construct a
  'ManyTypes' and thus lets us enforce the invariant that 'ManyTypes' will always have more
  than 1 argument. This lets us make sure that there's only ever one way to represent a list of
  'TypeRep's using 'Body'.

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

instance (Typeable a, Typeable b) => AllTypeable '[a, b] where
  typeReps :: [TypeRep]
typeReps = [forall a. Typeable a => TypeRep
typeRepOf @a, forall a. Typeable a => TypeRep
typeRepOf @b]

instance (Typeable a, AllTypeable (b ': c ': as)) => AllTypeable (a ': b ': c ': as) where
  typeReps :: [TypeRep]
typeReps = forall a. Typeable a => TypeRep
typeRepOf @a forall a. a -> [a] -> [a]
: forall (as :: [*]). AllTypeable as => [TypeRep]
typeReps @(b ': c ': as)