{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Linnet.ToResponse
  ( ToResponse(..)
  ) where

import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
import Data.Proxy (Proxy(..))
import GHC.Base (Symbol)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Linnet.Encode (Encode(..))
import Linnet.Internal.Coproduct (CNil, Coproduct(..))
import Network.HTTP.Types (status200, status404)
import Network.Wai (Response, responseLBS)

-- | Type-class to convert a value of type @a@ into Response with Content-Type of @ct@
class ToResponse (ct :: Symbol) a where
  toResponse :: a -> Response

instance (ToResponse' (ValueT a) ct a) => ToResponse ct a where
  toResponse = toResponse' @(ValueT a) @ct

class ToResponse' (value :: Value) (ct :: Symbol) a where
  toResponse' :: a -> Response

instance (Encode ct a, KnownSymbol ct) => ToResponse' 'Value ct a where
  toResponse' a = mkResponse @ct $ encode @ct a

instance ToResponse' 'ResponseValue ct Response where
  toResponse' = id

instance (KnownSymbol ct) => ToResponse' 'UnitValue ct () where
  toResponse' _ = mkResponse @ct mempty

instance ToResponse' 'CNilValue ct CNil where
  toResponse' _ = responseLBS status404 [] mempty

instance (ToResponse ct a, ToResponse ct b) => ToResponse' 'CoproductValue ct (Coproduct a b) where
  toResponse' (Inl a) = toResponse @ct a
  toResponse' (Inr b) = toResponse @ct b

mkResponse ::
     forall ct. (KnownSymbol ct)
  => BL.ByteString
  -> Response
mkResponse = responseLBS status200 [("Content-Type", C8.pack $ symbolVal (Proxy :: Proxy ct))]

data Value
  = Value
  | ResponseValue
  | CoproductValue
  | CNilValue
  | UnitValue

type family ValueT (a :: *) :: Value where
  ValueT (Coproduct _ _) = 'CoproductValue
  ValueT CNil = 'CNilValue
  ValueT Response = 'ResponseValue
  ValueT () = 'UnitValue
  ValueT _ = 'Value