From: PHO Date: Wed, 23 Nov 2011 15:06:25 +0000 (+0900) Subject: docs X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=01fe22b;p=Lucu.git docs Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/Lucu.cabal b/Lucu.cabal index 9a3e296..8703d04 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -119,7 +119,6 @@ Library Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage Network.HTTP.Lucu.Dispatcher.Internal - Network.HTTP.Lucu.Dispatcher.Node Network.HTTP.Lucu.Interaction Network.HTTP.Lucu.MIMEParams.Internal Network.HTTP.Lucu.OrphanInstances diff --git a/Network/HTTP/Lucu/Dispatcher.hs b/Network/HTTP/Lucu/Dispatcher.hs index dd37fb8..67838b0 100644 --- a/Network/HTTP/Lucu/Dispatcher.hs +++ b/Network/HTTP/Lucu/Dispatcher.hs @@ -5,10 +5,9 @@ module Network.HTTP.Lucu.Dispatcher , HostMapper(..) , HostMap , ResourceMapper(..) + , ResourceMap , ResourceTree , ResourceNode - , ResourceMap ) where import Network.HTTP.Lucu.Dispatcher.Internal -import Network.HTTP.Lucu.Dispatcher.Node diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs index f86eb1f..88b1e16 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -11,6 +11,7 @@ , UndecidableInstances , UnicodeSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} module Network.HTTP.Lucu.Dispatcher.Internal ( SchemeMapper(..) , SchemeMap @@ -19,6 +20,7 @@ module Network.HTTP.Lucu.Dispatcher.Internal , ResourceMapper(..) , ResourceMap , ResourceTree + , ResourceNode , dispatch ) @@ -27,14 +29,13 @@ import Control.Applicative hiding (empty) import Control.Monad.Trans.Maybe import Control.Monad.Unicode import Data.Collections -import qualified Data.Collections.Newtype.TH as C +import qualified Data.Map as M import Data.Monoid import Data.Monoid.Unicode -import Network.HTTP.Lucu.Dispatcher.Node import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Utils import Network.URI hiding (path) -import Prelude hiding (lookup) +import Prelude hiding (filter, lookup, null) import Prelude.Unicode -- |FIXME: docs @@ -73,10 +74,19 @@ class ResourceMapper α where -- |Container type for the 'ResourceMapper' type class. data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α --- FIXME: doc +-- |FIXME: doc newtype ResourceTree = Root ResourceNode deriving (Monoid, Show) +-- |FIXME: docs +data ResourceNode + = Greedy !Resource + | NonGreedy !Resource !SubTree + | Branch !SubTree + +type SubTree + = M.Map PathSegment ResourceNode + -- Instances of SchemeMapper -------------------------------------------------- instance SchemeMapper SchemeMap where {-# INLINE findHostMap #-} @@ -124,6 +134,7 @@ instance Monoid SchemeMap where {-# INLINE mappend #-} mappend = insert +-- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's. instance Map α Scheme HostMap ⇒ SchemeMapper α where {-# INLINE findHostMap #-} findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup @@ -176,6 +187,7 @@ instance Monoid HostMap where {-# INLINE mappend #-} mappend = insert +-- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's. instance Map α Host ResourceMap ⇒ HostMapper α where {-# INLINE findResourceMap #-} findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup @@ -221,6 +233,8 @@ instance Monoid ResourceMap where {-# INLINE mappend #-} mappend = insert +-- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@ +-- are also 'ResourceMapper's. instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where {-# INLINE findResource #-} findResource = (maybe (fail (⊥)) return ∘) ∘ lookup @@ -236,8 +250,56 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where findResource = (maybe (fail (⊥)) return ∘) ∘ flip id -- Instances of ResourceTree -------------------------------------------------- -C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode) - |] +instance Unfoldable ResourceTree (PathSegments, ResourceNode) where + {-# INLINEABLE insert #-} + insert (p, a) (Root b) = Root $ insertNodeAt (canonPath p) a b + {-# INLINE empty #-} + empty = Root $ Branch (∅) + +canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c +{-# INLINEABLE canonPath #-} +canonPath = filter ((¬) ∘ null) + +insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode +{-# INLINEABLE insertNodeAt #-} +insertNodeAt p a b + = case front p of + Nothing → a ⊕ b + Just (x, xs) + | null xs → Branch (singleton (x, a)) ⊕ b + | otherwise → insertNodeAt xs a (∅) ⊕ b + +instance Foldable ResourceTree (PathSegments, ResourceNode) where + foldMap f (Root n) = go (∅) n + where + go p (Greedy r ) = f (p, Greedy r) + go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m + go p (Branch m) = go' p m + + go' p = foldMap $ \(s, n') → go (p `snoc` s) n' + + null (Root (Greedy _ )) = False + null (Root (NonGreedy _ _)) = False + null (Root (Branch m)) = null m + + +-- Instances of ResourceNode -------------------------------------------------- +instance Show ResourceNode where + show (Greedy _ ) = "Greedy _" + show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m + show (Branch m) = "Branch " ⊕ show m + +instance Monoid ResourceNode where + {-# INLINE mempty #-} + mempty = Branch (∅) + {-# INLINEABLE mappend #-} + mappend (Greedy r ) _ = Greedy r + mappend (NonGreedy r m) (Greedy _ ) = NonGreedy r m + mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n) + mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n) + mappend (Branch _) (Greedy r ) = Greedy r + mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n) + mappend (Branch m) (Branch n) = Branch (m ⊕ n) -- dispatch ------------------------------------------------------------------- dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource) diff --git a/Network/HTTP/Lucu/Dispatcher/Node.hs b/Network/HTTP/Lucu/Dispatcher/Node.hs deleted file mode 100644 index 84989d7..0000000 --- a/Network/HTTP/Lucu/Dispatcher/Node.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE - FlexibleInstances - , MultiParamTypeClasses - , UnicodeSyntax - #-} -module Network.HTTP.Lucu.Dispatcher.Node - ( ResourceNode - ) - where -import Data.Collections -import qualified Data.Map as M -import Data.Monoid -import Data.Monoid.Unicode -import Network.HTTP.Lucu.Resource.Internal -import Network.HTTP.Lucu.Utils -import Prelude hiding (filter, null) -import Prelude.Unicode - --- FIXME: docs -data ResourceNode - = Greedy !Resource - | NonGreedy !Resource !SubTree - | Branch !SubTree - -type SubTree - = M.Map PathSegment ResourceNode - -instance Show ResourceNode where - show (Greedy _ ) = "Greedy _" - show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m - show (Branch m) = "Branch " ⊕ show m - -instance Monoid ResourceNode where - {-# INLINE mempty #-} - mempty = Branch (∅) - {-# INLINEABLE mappend #-} - mappend (Greedy r ) _ = Greedy r - mappend (NonGreedy r m) (Greedy _ ) = NonGreedy r m - mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n) - mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n) - mappend (Branch _) (Greedy r ) = Greedy r - mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n) - mappend (Branch m) (Branch n) = Branch (m ⊕ n) - -instance Unfoldable ResourceNode (PathSegments, ResourceNode) where - {-# INLINEABLE insert #-} - insert (p, n) = insertNodeAt (canonPath p) n - {-# INLINE empty #-} - empty = Branch (∅) - -canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c -{-# INLINEABLE canonPath #-} -canonPath = filter ((¬) ∘ null) - -insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode -{-# INLINEABLE insertNodeAt #-} -insertNodeAt p a b - = case front p of - Nothing → a ⊕ b - Just (x, xs) - | null xs → Branch (singleton (x, a)) ⊕ b - | otherwise → insertNodeAt xs a (∅) ⊕ b - -instance Foldable ResourceNode (PathSegments, ResourceNode) where - foldMap f = go (∅) - where - go p (Greedy r ) = f (p, Greedy r) - go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m - go p (Branch m) = go' p m - - go' p = foldMap $ \(s, n) → go (p `snoc` s) n - - null (Greedy _ ) = False - null (NonGreedy _ _) = False - null (Branch m) = null m diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 03fde6b..e1abcab 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -46,6 +46,7 @@ import Prelude.Unicode -- > = Just $ do setContentType [mimeType| text/plain |] -- > putChunk "Hello, world!" -- > } +-- -- FIXME: update the above example runHttpd ∷ Config → SchemeMap → IO () runHttpd cnf sm