{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Language.Symantic.HTTP.Sym
 ( module Language.Symantic.HTTP.Sym
 , Functor(..), (<$>), ($>)
 , Applicative(..)
 , Alternative(..)
 ) where

import Control.Applicative (Applicative(..), Alternative(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>), ($>), (<$))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.String (String)
import Text.Show (Show(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai

-- * Class 'HTTP_Server'
class
 ( Applicative    repr
 , Altern         repr
 , HTTP_Path      repr
 , HTTP_Method    repr
 , HTTP_Header    repr
 , HTTP_Accept    repr
 , HTTP_Response  repr
 , HTTP_Query     repr
 , HTTP_Version   repr
 ) => HTTP_Server repr

-- * Class 'Altern'
class Altern repr where
	-- | There Is No Alternative
	tina :: repr a
	(<+>) :: repr a -> repr a -> repr a; infixl 3 <+>
	try :: repr a -> repr a
	choice :: [repr a] -> repr a
	choice [] = tina
	choice (r:rs) = try r <+> choice rs
-- * Class 'HTTP_Path'
class HTTP_Path repr where
	segment    :: Segment -> repr ()
	capture    :: Name -> repr Segment
	captureAll :: repr [Segment]
-- * Class 'HTTP_Method'
class HTTP_Method repr where
	method         :: HTTP.Method -> repr HTTP.Method
	method_GET     :: repr HTTP.Method
	method_POST    :: repr HTTP.Method
	method_HEAD    :: repr HTTP.Method
	method_PUT     :: repr HTTP.Method
	method_DELETE  :: repr HTTP.Method
	method_TRACE   :: repr HTTP.Method
	method_CONNECT :: repr HTTP.Method
	method_OPTIONS :: repr HTTP.Method
	method_PATCH   :: repr HTTP.Method
	method_GET     = method HTTP.methodGet
	method_HEAD    = method HTTP.methodHead
	method_PUT     = method HTTP.methodPut
	method_POST    = method HTTP.methodPost
	method_DELETE  = method HTTP.methodDelete
	method_TRACE   = method HTTP.methodTrace
	method_CONNECT = method HTTP.methodConnect
	method_OPTIONS = method HTTP.methodOptions
	method_PATCH   = method HTTP.methodPatch
-- * Class 'HTTP_Header'
class HTTP_Header repr where
	header :: HTTP.HeaderName -> repr HeaderValue
-- * Class 'HTTP_Response'
class HTTP_Response repr where
	response ::
	 ToMediaType mt a =>
	 HTTP.Method ->
	 Proxy mt ->
	 repr (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
-- * Class 'HTTP_Accept'
data AcceptResponse repr a =
 forall mt. ToMediaType mt a =>
 AcceptResponse (Proxy mt, repr a)
class HTTP_Accept repr where
	accept :: ToMediaType mt a => Proxy mt -> repr (a -> BSL.ByteString)
	{-
	acceptCase :: Functor repr => Altern repr => [AcceptResponse repr a] -> repr BSL.ByteString
	acceptCase [] = tina $> BSL.empty
	acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
	-}
-- * Class 'HTTP_Query'
class HTTP_Query repr where
	query     :: QueryName -> repr [Maybe QueryValue]
	queryFlag :: QueryName -> repr Bool
-- * Class 'HTTP_Version'
class HTTP_Version repr where
	version :: HTTP.HttpVersion -> repr HTTP.HttpVersion
-- * Class 'HTTP_Status'
class HTTP_Status repr where
	status :: StatusIs -> repr HTTP.Status
-- ** Type 'StatusIs'
data StatusIs
 =   StatusIsInformational
 |   StatusIsSuccessful
 |   StatusIsRedirection
 |   StatusIsClientError
 |   StatusIsServerError
 |   StatusIs HTTP.Status
 deriving (Eq, Ord, Show)
statusIs :: StatusIs -> (HTTP.Status -> Bool)
statusIs = \case
 StatusIsInformational -> HTTP.statusIsInformational
 StatusIsSuccessful    -> HTTP.statusIsSuccessful
 StatusIsRedirection   -> HTTP.statusIsRedirection
 StatusIsClientError   -> HTTP.statusIsClientError
 StatusIsServerError   -> HTTP.statusIsServerError
 StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y

type Name        = String
type Value       = String
type Segment     = T.Text
type Path        = [Segment]
-- type Headers     = HM.HashMap HTTP.HeaderName [HeaderValue]
type HeaderValue = BS.ByteString
-- type Query       = HM.HashMap QueryName [QueryValue]
type QueryName   = BS.ByteString
type QueryValue  = BS.ByteString
type MediaType   = Media.MediaType