{-# 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 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      Media.MediaType
 |   LayoutNode_Body
 |   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_Query Layout where
	queryParams' = layoutOfNode . LayoutNode_QueryParams
	queryFlag    = layoutOfNode . LayoutNode_QueryFlag
instance HTTP_Version Layout where
	version = layoutOfNode . LayoutNode_Version
data LayoutBodyArg mt a = LayoutBodyArg
instance HTTP_Body Layout where
	type BodyArg Layout = LayoutBodyArg
	body' = layoutOfNode $ LayoutNode_Body
data LayoutResponseArg mt a = LayoutResponseArg
instance HTTP_Response Layout where
	type Response    Layout = ()
	type ResponseArg Layout = LayoutResponseArg
	response ::
	 forall repr k a mt.
	 MimeSerialize a mt =>
	 MimeUnserialize a mt =>
	 k ~ Response repr =>
	 repr ~ Layout =>
	 HTTP.Method ->
	 repr (ResponseArg repr mt a -> k) k
	response me =
		reLayout $ method <.> accept
		where
		method = layoutOfNode $ LayoutNode_Method me
		accept = layoutOfNode $ LayoutNode_Accept $ mimeType (Proxy::Proxy mt)
instance HTTP_API Layout