module Web.Minion.Response.Union where

import Data.Kind
import Web.Minion

data Union (as :: [Type]) where
  This :: !a -> Union (a ': as)
  That :: !(Union as) -> Union (a ': as)

class Inject a as where
  inject :: a -> Union as

instance Inject a (a ': as) where
  inject :: a -> Union (a : as)
inject = a -> Union (a : as)
forall a (as :: [*]). a -> Union (a : as)
This

instance {-# OVERLAPPABLE #-} (Inject a as) => Inject a (x ': as) where
  inject :: a -> Union (x : as)
inject = Union as -> Union (x : as)
forall (as :: [*]) a. Union as -> Union (a : as)
That (Union as -> Union (x : as))
-> (a -> Union as) -> a -> Union (x : as)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Union as
forall a (as :: [*]). Inject a as => a -> Union as
inject

instance (CanRespond a, CanRespond (Union as)) => CanRespond (Union (a ': as)) where
  canRespond :: [ByteString] -> Bool
canRespond [ByteString]
h = forall o. CanRespond o => [ByteString] -> Bool
forall {k} (o :: k). CanRespond o => [ByteString] -> Bool
canRespond @a [ByteString]
h Bool -> Bool -> Bool
&& forall o. CanRespond o => [ByteString] -> Bool
forall {k} (o :: k). CanRespond o => [ByteString] -> Bool
canRespond @(Union as) [ByteString]
h

instance CanRespond (Union '[]) where
  canRespond :: [ByteString] -> Bool
canRespond [ByteString]
_ = Bool
True

instance (ToResponse m a, Monad m, ToResponse m (Union as)) => ToResponse m (Union (a ': as)) where
  toResponse :: [ByteString] -> Union (a : as) -> m Response
toResponse [ByteString]
accept = \case
    This a
a -> [ByteString] -> a -> m Response
forall (m :: * -> *) r.
ToResponse m r =>
[ByteString] -> r -> m Response
toResponse [ByteString]
accept a
a
    That Union as
as -> [ByteString] -> Union as -> m Response
forall (m :: * -> *) r.
ToResponse m r =>
[ByteString] -> r -> m Response
toResponse [ByteString]
accept Union as
as

instance (Monad m) => ToResponse m (Union '[]) where
  toResponse :: [ByteString] -> Union '[] -> m Response
toResponse [ByteString]
_ = [Char] -> Union '[] -> m Response
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"