{-# 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.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.Types as HTTP

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_Accept      MediaTypes
 |   LayoutNode_Body        MediaTypes
 |   LayoutNode_BodyStream
 |   LayoutNode_BasicAuth   BasicAuthRealm
 |   LayoutNode_Capture     Name
 |   LayoutNode_CaptureAll
 |   LayoutNode_Header      HTTP.HeaderName
 |   LayoutNode_Headers     HTTP.RequestHeaders
 |   LayoutNode_Method      HTTP.Method
 |   LayoutNode_QueryFlag   QueryName
 |   LayoutNode_QueryParams QueryName
 |   LayoutNode_QueryString HTTP.Query
 |   LayoutNode_Segment     Segment
 |   LayoutNode_Version     HTTP.HttpVersion
 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]
instance Pro Layout where
	dimap _a2b _b2a = reLayout
instance HTTP_Path Layout where
	segment    = layoutOfNode . LayoutNode_Segment
	capture'   = layoutOfNode . LayoutNode_Capture
	captureAll = layoutOfNode $ LayoutNode_CaptureAll
instance HTTP_Header Layout where
	header = layoutOfNode . LayoutNode_Header
instance HTTP_BasicAuth Layout where
	type BasicAuthArgs Layout a k = k
	basicAuth' = layoutOfNode . LayoutNode_BasicAuth
instance HTTP_Query Layout where
	queryParams' = layoutOfNode . LayoutNode_QueryParams
	queryFlag    = layoutOfNode . LayoutNode_QueryFlag
instance HTTP_Version Layout where
	version = layoutOfNode . LayoutNode_Version
data LayoutBodyArg a (ts::[*]) = LayoutBodyArg
instance HTTP_Body Layout where
	type BodyConstraint Layout a ts = MimeTypes ts (MimeDecodable a)
	type BodyArg Layout a ts = LayoutBodyArg a ts
	body' ::
	 forall a ts k repr.
	 BodyConstraint repr a ts =>
	 repr ~ Layout =>
	 repr (BodyArg repr a ts -> k) k
	body' = layoutOfNode $ LayoutNode_Body $ mediaTypes @ts @(MimeDecodable a)
data LayoutBodyStreamArg framing (ts::[*]) as = LayoutBodyStreamArg
instance HTTP_BodyStream Layout where
	type BodyStreamConstraint Layout as ts framing =
	 MimeTypes ts (MimeDecodable (FramingYield as))
	type BodyStreamArg Layout as ts framing =
	 LayoutBodyStreamArg framing ts as
	bodyStream' ::
	 forall as ts framing k repr.
	 BodyStreamConstraint repr as ts framing =>
	 repr ~ Layout =>
	 repr (BodyStreamArg repr as ts framing -> k) k
	bodyStream' = layoutOfNode $ LayoutNode_BodyStream
data LayoutResponseArgs a (ts::[*]) = LayoutResponseArgs
instance HTTP_Response Layout where
	type ResponseConstraint Layout a ts = MimeTypes ts (MimeEncodable a)
	type ResponseArgs Layout a ts = LayoutResponseArgs a ts
	type Response Layout = ()
	response ::
	 forall a ts repr.
	 ResponseConstraint repr a ts =>
	 repr ~ Layout =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr)
	response me =
		reLayout $ method <.> accept
		where
		method = layoutOfNode $ LayoutNode_Method me
		accept = layoutOfNode $ LayoutNode_Accept $ mediaTypes @ts @(MimeEncodable a)
instance HTTP_API Layout