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

import Control.Applicative (Applicative(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
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.ByteString.Lazy as BSL
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 Language.Symantic.HTTP.Media
import Language.Symantic.HTTP.API

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

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

instance Show (Layout a) where
	show = drawForest . runLayout

reLayout :: Layout a -> Layout b
reLayout (Layout l) = Layout l

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

layoutOfNode :: LayoutNode -> Layout a
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 where
	fmap _f = reLayout
instance Applicative Layout where
	pure _ = Layout []
	Layout x <*> Layout y = Layout $ x <> y
instance Altern Layout where
	tina = Layout []
	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 = Proxy
	endpoint me mt =
		(\(Layout l::Layout (a -> BSL.ByteString)) ->
			Layout l::Layout (Endpoint Layout a)) $
		method me *> accept mt
instance HTTP_API Layout