From: PHO <pho@cielonegro.org>
Date: Wed, 23 Nov 2011 13:32:36 +0000 (+0900)
Subject: Still working on Dispatcher...
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=dc20568c7c323ea2193326aab48f236fa3817191

Still working on Dispatcher...

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---

diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs
index f8f3b12..71e5ffd 100644
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -77,8 +77,11 @@ newtype ResourceTree = Root ResourceNode
 -- FIXME: docs
 data ResourceNode
     = Greedy    !Resource
-    | NonGreedy !Resource !ResourceTree
-    | Branch              !ResourceTree
+    | NonGreedy !Resource !SubTree
+    | Branch              !SubTree
+
+type SubTree
+    = M.Map PathSegment ResourceNode
 
 -- Instances of SchemeMapper --------------------------------------------------
 instance SchemeMapper SchemeMap where
@@ -116,7 +119,7 @@ instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
     {-# INLINE singleton #-}
     singleton = schemeMap
 
--- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 instance Monoid SchemeMap where
     {-# INLINE mempty #-}
     mempty = schemeMap e
@@ -168,7 +171,7 @@ instance HostMapper α ⇒ Unfoldable HostMap α where
     {-# INLINE singleton #-}
     singleton = hostMap
 
--- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 instance Monoid HostMap where
     {-# INLINE mempty #-}
     mempty = hostMap e
@@ -213,7 +216,7 @@ instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
     {-# INLINE singleton #-}
     singleton = resourceMap
 
--- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+-- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 instance Monoid ResourceMap where
     {-# INLINE mempty #-}
     mempty = resourceMap e
@@ -239,28 +242,23 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 
 -- Instances of ResourceTree --------------------------------------------------
-{-
-instance (Functor m, MonadIO m)
-       ⇒ Unfoldable (ResourceTree m) ([PathSegment], ResourceNode m) where
+instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
     {-# INLINE insert #-}
     insert e (Root root) = Root $ insert e root
     {-# INLINE empty #-}
     empty = (∅)
 
-instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) where
+instance Monoid ResourceTree where
     {-# INLINE mempty #-}
     mempty = Root (∅)
     {-# INLINE mappend #-}
     mappend (Root a) (Root b)
         = Root (a ⊕ b)
--}
 
 -- Instances of ResourceNode --------------------------------------------------
-{-
-instance (Functor m, MonadIO m)
-       ⇒ Unfoldable (ResourceNode m) ([PathSegment], ResourceNode m) where
+instance Unfoldable ResourceNode (PathSegments, ResourceNode) where
     {-# INLINEABLE insert #-}
-    insert (p, a) b = insertNodeAt (canonPath p) a b
+    insert (p, n) = insertNodeAt (canonPath p) n
     {-# INLINE empty #-}
     empty = Branch (∅)
 
@@ -268,17 +266,16 @@ canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
 {-# INLINEABLE canonPath #-}
 canonPath = filter ((¬) ∘ null)
 
-insertNodeAt ∷ (Functor m, MonadIO m)
-             ⇒ [PathSegment]
-             → ResourceNode m
-             → ResourceNode m
-             → ResourceNode m
+insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode
 {-# INLINEABLE insertNodeAt #-}
-insertNodeAt []     a b = a ⊕ b
-insertNodeAt (x:[]) a b = Branch (singleton (x, a)) ⊕ b
-insertNodeAt (x:xs) a b = insertNodeAt xs a (∅) ⊕ b
-
-instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where
+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 Monoid ResourceNode where
     {-# INLINE mempty #-}
     mempty = Branch (∅)
     {-# INLINEABLE mappend #-}
@@ -289,7 +286,6 @@ instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where
     mappend (Greedy    r  ) (Branch      _) = Greedy    r
     mappend (NonGreedy r m) (Branch      n) = NonGreedy r (m ⊕ n)
     mappend (Branch      m) (Branch      n) = Branch      (m ⊕ n)
--}
 
 -- dispatch -------------------------------------------------------------------
 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)