Symantic/HTTP/Layout.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE InstanceSigs #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Symantic.HTTP.Layout where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($), (.), id)
  11 import Data.Functor (Functor(..), (<$>))
  12 import Data.Ord (Ord(..))
  13 import Data.Proxy (Proxy(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String)
  16 import Data.Tree (Tree(..), Forest, drawForest)
  17 import Text.Show (Show(..))
  18 import qualified Data.List as List
  19 import qualified Network.HTTP.Media as Media
  20 import qualified Network.HTTP.Types as HTTP
  21
  22 import Symantic.HTTP.Mime
  23 import Symantic.HTTP.API
  24
  25 -- * Type 'Layout'
  26 newtype Layout h k = Layout { unLayout :: LayoutApp (LayoutAlt (Tree LayoutNode)) }
  27 -- | Branches of alternatives matches.
  28 type LayoutAlt = []
  29 -- | Keep the path in the 'Tree'
  30 -- where to append new matchers;
  31 -- in reverse order to simplify appending.
  32 type LayoutApp = []
  33
  34 -- | Useful to constrain 'repr' to be 'Layout'.
  35 layout :: Layout h k -> Layout h k
  36 layout = id
  37
  38 runLayout :: Layout h k -> Forest String
  39 runLayout = ((show <$>) <$>) . collapseApp . unLayout
  40
  41 instance Show (Layout h k) where
  42         show = drawForest . runLayout
  43
  44 reLayout :: Layout h k -> Layout h' k'
  45 reLayout (Layout l) = Layout l
  46
  47 -- | Fold 'LayoutApp' maintained for appending matchers;
  48 -- to be done when there is no more appending.
  49 collapseApp :: LayoutApp (LayoutAlt (Tree LayoutNode)) -> LayoutAlt (Tree LayoutNode)
  50 collapseApp = (`List.foldr` []) $ \ts acc ->
  51         ((\(Node n ns) -> Node n (ns <> acc)) <$> ts)
  52
  53 layoutOfNode :: LayoutNode -> Layout h k
  54 layoutOfNode = Layout . pure . pure . pure
  55
  56 -- ** Type 'LayoutNode'
  57 data LayoutNode
  58  =   LayoutNode_Accept      Media.MediaType
  59  |   LayoutNode_Body
  60  |   LayoutNode_BasicAuth   BasicAuthRealm
  61  |   LayoutNode_Capture     Name
  62  |   LayoutNode_CaptureAll
  63  |   LayoutNode_Header      HTTP.HeaderName
  64  |   LayoutNode_Headers     HTTP.RequestHeaders
  65  |   LayoutNode_Method      HTTP.Method
  66  |   LayoutNode_QueryFlag   QueryName
  67  |   LayoutNode_QueryParams QueryName
  68  |   LayoutNode_QueryString HTTP.Query
  69  |   LayoutNode_Segment     Segment
  70  |   LayoutNode_Version     HTTP.HttpVersion
  71  deriving (Eq, Ord, Show)
  72
  73 type instance HttpApiData Layout = LayoutHttpApiData
  74 class LayoutHttpApiData a
  75 instance LayoutHttpApiData a
  76 instance Functor (Layout h) where
  77         fmap _f = reLayout
  78 instance Cat Layout where
  79         Layout x <.> Layout y = Layout $ x <> y
  80 instance Alt Layout where
  81         Layout x <!> Layout y =
  82                 Layout [collapseApp x <> collapseApp y]
  83 instance Pro Layout where
  84         dimap _a2b _b2a = reLayout
  85 instance HTTP_Path Layout where
  86         segment    = layoutOfNode . LayoutNode_Segment
  87         capture'   = layoutOfNode . LayoutNode_Capture
  88         captureAll = layoutOfNode $ LayoutNode_CaptureAll
  89 instance HTTP_Header Layout where
  90         header = layoutOfNode . LayoutNode_Header
  91 instance HTTP_BasicAuth Layout where
  92         type BasicAuthArgs Layout a k = k
  93         basicAuth' = layoutOfNode . LayoutNode_BasicAuth
  94 instance HTTP_Query Layout where
  95         queryParams' = layoutOfNode . LayoutNode_QueryParams
  96         queryFlag    = layoutOfNode . LayoutNode_QueryFlag
  97 instance HTTP_Version Layout where
  98         version = layoutOfNode . LayoutNode_Version
  99 data LayoutBodyArg a (mt::[*]) = LayoutBodyArg
 100 instance HTTP_Body Layout where
 101         type BodyArg Layout = LayoutBodyArg
 102         body' = layoutOfNode $ LayoutNode_Body
 103 instance HTTP_Response Layout where
 104         {-
 105         type Response     Layout = ()
 106         type ResponseArgs Layout mt a k = k
 107         response ::
 108          MimeCodable repr a mt =>
 109          k ~ Response repr =>
 110          repr ~ Layout =>
 111          HTTP.Method ->
 112          repr (ResponseArgs repr mt a k) k
 113         response me =
 114                 reLayout $ method <.> accept
 115                 where
 116                 method = layoutOfNode $ LayoutNode_Method me
 117                 accept = layoutOfNode $ LayoutNode_Accept $ mimeType (Proxy::Proxy mt)
 118         -}
 119 instance HTTP_API Layout