X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=6cb741d55f62dbd26a9c80cb80b4d211144d98e7;hb=ff68f4a2426b044441bf6a8b966c4fedd89af6ad;hp=71e5ffd211659b6af3dc8019b6db3f92e3c17eea;hpb=dc20568c7c323ea2193326aab48f236fa3817191;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs
index 71e5ffd..6cb741d 100644
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -2,13 +2,16 @@
     DoAndIfThenElse
   , ExistentialQuantification
   , FlexibleInstances
+  , GeneralizedNewtypeDeriving
   , OverlappingInstances
   , MultiParamTypeClasses
   , RecordWildCards
   , ScopedTypeVariables
+  , TemplateHaskell
   , UndecidableInstances
   , UnicodeSyntax
   #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
 module Network.HTTP.Lucu.Dispatcher.Internal
     ( SchemeMapper(..)
     , SchemeMap
@@ -71,12 +74,13 @@ 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
+-- |FIXME: docs
 data ResourceNode
-    = Greedy    !Resource
+    = Greedy    !Resource !SubTree
     | NonGreedy !Resource !SubTree
     | Branch              !SubTree
 
@@ -130,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
@@ -182,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
@@ -227,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
@@ -243,24 +251,10 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
 
 -- Instances of ResourceTree --------------------------------------------------
 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
-    {-# INLINE insert #-}
-    insert e (Root root) = Root $ insert e root
-    {-# INLINE empty #-}
-    empty = (∅)
-
-instance Monoid ResourceTree where
-    {-# INLINE mempty #-}
-    mempty = Root (∅)
-    {-# INLINE mappend #-}
-    mappend (Root a) (Root b)
-        = Root (a ⊕ b)
-
--- Instances of ResourceNode --------------------------------------------------
-instance Unfoldable ResourceNode (PathSegments, ResourceNode) where
     {-# INLINEABLE insert #-}
-    insert (p, n) = insertNodeAt (canonPath p) n
+    insert (p, a) (Root b) = Root $ insertNodeAt (canonPath p) a b
     {-# INLINE empty #-}
-    empty = Branch (∅)
+    empty = Root $ Branch (∅)
 
 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
 {-# INLINEABLE canonPath #-}
@@ -275,16 +269,40 @@ insertNodeAt p a b
             | 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 m) = go' p m ⊕ f (p, Greedy    r (∅))
+          go p (NonGreedy r m) = go' p m ⊕ f (p, NonGreedy r (∅))
+          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
+
+instance Collection ResourceTree (PathSegments, ResourceNode) where
+    {-# INLINE filter #-}
+    filter f = fromList ∘ filter f ∘ fromFoldable
+
+
+-- Instances of ResourceNode --------------------------------------------------
+instance Show ResourceNode where
+    show (Greedy    _ m) = "Greedy _ " ⊕ show m
+    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 (Greedy    _  ) (NonGreedy r n) = NonGreedy r      n
-    mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
-    mappend (Branch      m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
-    mappend (Greedy    r  ) (Branch      _) = Greedy    r
+    mappend (Greedy    r m) _               = Greedy    r      m
+    mappend (NonGreedy r m) (Greedy    _ n) = NonGreedy r (m ⊕ n)
+    mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n)
     mappend (NonGreedy r m) (Branch      n) = NonGreedy r (m ⊕ n)
+    mappend (Branch      m) (Greedy    r n) = Greedy    r (m ⊕ n)
+    mappend (Branch      m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
     mappend (Branch      m) (Branch      n) = Branch      (m ⊕ n)
 
 -- dispatch -------------------------------------------------------------------