{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.HTTP.Layout where

import Control.Applicative (Applicative(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Tree (Tree(..), Forest, drawForest)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
-- import qualified Network.Wai as Wai

import Symantic.HTTP.Media
import Symantic.HTTP.Mime
import Symantic.HTTP.API

-- * Type 'Layout'
newtype Layout h k = Layout { unLayout :: LayoutApp (LayoutAlt (Tree LayoutNode)) }
-- | Branches of alternatives matches.
type LayoutAlt = []
-- | Keep the path in the 'Tree'
-- where to append new matchers;
-- in reverse order to simplify appending.
type LayoutApp = []

-- | Useful to constrain 'repr' to be 'Layout'.
layout :: Layout h k -> Layout h k
layout = id

runLayout :: Layout h k -> Forest String
runLayout = ((show <$>) <$>) . collapseApp . unLayout

instance Show (Layout h k) where
	show = drawForest . runLayout

reLayout :: Layout h k -> Layout h' k'
reLayout (Layout l) = Layout l

-- | Fold 'LayoutApp' maintained for appending matchers;
-- to be done when there is no more appending.
collapseApp :: LayoutApp (LayoutAlt (Tree LayoutNode)) -> LayoutAlt (Tree LayoutNode)
collapseApp = (`List.foldr` []) $ \ts acc ->
	((\(Node n ns) -> Node n (ns <> acc)) <$> ts)

layoutOfNode :: LayoutNode -> Layout h k
layoutOfNode = Layout . pure . pure . pure

-- ** Type 'LayoutNode'
data LayoutNode
 =   LayoutNode_Segment     Segment
 |   LayoutNode_Capture     Name
 |   LayoutNode_CaptureAll
 |   LayoutNode_Header      HTTP.HeaderName
 |   LayoutNode_Headers     HTTP.RequestHeaders
 |   LayoutNode_Query       QueryName
 |   LayoutNode_QueryFlag   QueryName
 |   LayoutNode_QueryString HTTP.Query
 |   LayoutNode_Method      HTTP.Method
 |   LayoutNode_Version     HTTP.HttpVersion
 |   LayoutNode_Accept      Media.MediaType
 deriving (Eq, Ord, Show)

instance Functor (Layout h) where
	fmap _f = reLayout
instance Cat Layout where
	Layout x <.> Layout y = Layout $ x <> y
instance Alt Layout where
	Layout x <!> Layout y =
		Layout [collapseApp x <> collapseApp y]
	try = id
instance HTTP_Path Layout where
	segment    = layoutOfNode . LayoutNode_Segment
	capture'   = layoutOfNode . LayoutNode_Capture
	captureAll = layoutOfNode $ LayoutNode_CaptureAll
instance HTTP_Method Layout where
	method = layoutOfNode . LayoutNode_Method
instance HTTP_Header Layout where
	header = layoutOfNode . LayoutNode_Header
instance HTTP_Accept Layout where
	accept mt = layoutOfNode $ LayoutNode_Accept (mediaType mt)
instance HTTP_Query Layout where
	query'    = layoutOfNode . LayoutNode_Query
	queryFlag = layoutOfNode . LayoutNode_QueryFlag
instance HTTP_Version Layout where
	version = layoutOfNode . LayoutNode_Version
{-
instance HTTP_Response Layout where
	response me mt =
		(\(Layout l::Layout (a -> BSL.ByteString)) ->
			Layout l::Layout (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
		) $
			method me *> accept mt
-}
instance HTTP_Endpoint Layout where
	type Endpoint Layout = ()
	type EndpointArg Layout = EndpointArgLayout
	endpoint' ::
	 forall repr k mt a.
	 MimeSerialize mt a =>
	 MimeUnserialize mt a =>
	 k ~ Endpoint repr =>
	 repr ~ Layout =>
	 HTTP.Method ->
	 repr (EndpointArg repr mt a -> k) k
	endpoint' me = reLayout $ method me <.> accept (Proxy::Proxy mt)
instance HTTP_API Layout
data EndpointArgLayout mt body = EndpointArgLayout