{-# 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