X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=88b1e16cd07056110e78a93c440d89debcc10226;hp=f86eb1f4dacecf75bc5ef663e217b7828d208481;hb=01fe22bec14421e3b9430efbfc9daee05f181730;hpb=761b90ab4f413d2e83460f170082f3b15bbaef4f 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)