{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Symantic.HTTP.Mime.Type where

-- import Text.Show (Show(..))
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Kind (Constraint)
import Data.Maybe (Maybe(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Tuple (fst, snd)
import Data.Typeable (Typeable)
import qualified Data.ByteString as BS
import qualified Network.HTTP.Media as Media

-- * Class 'MediaTypeable'
class MediaTypeable mt where
	mediaType  :: Proxy mt -> MediaType
	mediaTypes :: Proxy mt -> [MediaType]
	mediaTypes mt = [mediaType mt]
type MediaType = Media.MediaType
instance MediaTypeable () where
	mediaType _mt = mimeAny

charsetUTF8 :: MediaType -> MediaType
charsetUTF8 = (Media./: ("charset", "utf-8"))

mimeAny :: MediaType
mimeAny = "*/*"

-- ** Type 'JSON'
data JSON deriving (Typeable)
instance MediaTypeable JSON where
	mediaType _mt = charsetUTF8 $ "application"Media.//"json"
	mediaTypes mt = [mediaType mt, "application"Media.//"json"]

-- ** Type 'HTML'
data HTML
mimeHTML :: Proxy HTML
mimeHTML = Proxy
instance MediaTypeable HTML where
	mediaType _mt = charsetUTF8 $ "text"Media.//"html"
	mediaTypes mt = [mediaType mt, "text"Media.//"html"]

-- ** Type 'FormUrlEncoded'
data FormUrlEncoded
mimeFormUrlEncoded :: Proxy FormUrlEncoded
mimeFormUrlEncoded = Proxy
instance MediaTypeable FormUrlEncoded where
	mediaType _mt = "application"Media.//"x-www-form-urlencoded"

-- ** Type 'OctetStream'
data OctetStream
mimeOctetStream :: Proxy OctetStream
mimeOctetStream = Proxy
instance MediaTypeable OctetStream where
	mediaType _mt = "application"Media.//"octet-stream"

-- ** Type 'PlainText'
data PlainText
mimePlainText :: Proxy PlainText
mimePlainText = Proxy
instance MediaTypeable PlainText where
	mediaType _mt = charsetUTF8 $ "text"Media.//"plain"


-- * Type 'MimeType'
data MimeType c where
	MimeType :: c t => Proxy t -> MimeType c

-- ** Type 'MimeTypeT'
data MimeTypeT = forall t. MimeTypeT (MimeType t)

-- * Class 'MimeTypes'
class MimeTypes (ts::[*]) (c:: * -> Constraint) where
	mimeTypesMap :: [(MediaType, MimeType c)]
	 -- TODO: Map
instance
 (MediaTypeable t, c t) =>
 MimeTypes '[t] c where
	mimeTypesMap =
	 [ (t, MimeType @c @t Proxy)
	 | t <- mediaTypes (Proxy @t)
	 ]
instance
 ( MediaTypeable t
 , MediaTypeable t1
 , MimeTypes ts c
 , c t
 , c t1
 ) =>
 MimeTypes (t ': t1 ': ts) c where
	mimeTypesMap =
	 [ (t, MimeType @c @t Proxy)
	 | t <- mediaTypes (Proxy @t)
	 ] <>
	 [ (t, MimeType @c @t1 Proxy)
	 | t <- mediaTypes (Proxy @t1)
	 ] <> mimeTypesMap @ts @c

listMediaTypes :: forall ts c. MimeTypes ts c => [MediaType]
listMediaTypes = fst <$> mimeTypesMap @ts @c

listMimeTypes :: forall ts c. MimeTypes ts c => [MimeType c]
listMimeTypes = snd <$> mimeTypesMap @ts @c

matchAccept ::
 forall ts c. MimeTypes ts c =>
 BS.ByteString -> Maybe (MimeType c)
matchAccept = Media.mapAccept (mimeTypesMap @ts @c)

matchContent ::
 forall ts c. MimeTypes ts c =>
 BS.ByteString -> Maybe (MimeType c)
matchContent = Media.mapContent (mimeTypesMap @ts @c)

{-
class MediaTypeable t where
	mimeTypeParse :: BS.ByteString -> Maybe (MimeType t)

-- parseAccept :: Proxy ts -> BS.ByteString -> Maybe (MimeTypeIn ts t)

-- mimeDecode :: Proxy mt -> Unserializer a
-- * Class 'MimeTypesInj'
type MimeTypesInj  ts
 =   MimeTypesInjR ts ts

mimeTypeInj ::
 forall ts.
 MimeTypesInj ts =>
 Either Error_MimeType (MimeTypes ts)
mimeTypeInj = mimeTypeInjR @_ @ts

-- ** Class 'MimeTypesInjR'
class MimeTypesInjR (ts::[*]) (rs::[*]) where
	mimeTypeInjR :: Either Error_MimeType (MimeTypes ts)
instance MimeTypesInjR ts '[] where
	mimeTypeInjR = Right $ MimeTypes mempty
instance ( MimeTypeFor ts t
         , MimeTypesInjR ts rs
         ) => MimeTypesInjR ts (Proxy t ': rs) where
	mimeTypeInjR = do
		x <- mimeTypeInjR @_ @rs
		let (n, m) = moduleFor @_  @t
		MimeTypes (Map.singleton n m) `unionMimeTypes` x

-}
{-
MimeType ss s

-- | Return the position of a type within a list of them.
-- This is useful to work around @OverlappingInstances@.
type family Index xs x where
	Index (x     ': xs) x = Zero
	Index (not_x ': xs) x = Succ (Index xs x)

-- ** Type 'MimeTypeInj'
-- | Convenient type synonym wrapping 'MimeTypePInj'
-- applied on the correct 'Index'.
type MimeTypeInj ss s = MimeTypeInjP (Index ss (Proxy s)) ss s

-- | Inject a given /symantic/ @s@ into a list of them,
-- by returning a function which given a 'TeMimeType' on @s@
-- returns the same 'TeMimeType' on @ss@.
mimeTypeInj ::
 forall s ss.
 MimeTypeInj ss s =>
 MimeType '[Proxy s] ->
 MimeType ss
mimeTypeInj = mimeTypeInjP @(Index ss (Proxy s))

-- *** Class 'MimeTypePInj'
class MimeTypeInjP p ss s where
	mimeTypeInjP :: MimeType '[Proxy s] -> MimeType ss
instance MimeTypeInjP Zero (Proxy s ': ss) (s::k) where
	mimeTypeInjP (MimeType te) = MimeType te
instance MimeTypeInjP p ss s => MimeTypeInjP (Succ p) (Proxy not_s ': ss) s where
	mimeTypeInjP (te::MimeType '[Proxy s]) =
		case mimeTypeInjP @p te :: MimeType ss of
		 MimeType te' -> MimeType te'
-}