From e30ad424d38d9406a8cede15b2fb730bc138ce64 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Thu, 24 Nov 2011 21:33:08 +0900
Subject: [PATCH] Simplify the implementation of ResourceTree

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---
 Network/HTTP/Lucu/Dispatcher.hs          |   2 +
 Network/HTTP/Lucu/Dispatcher/Internal.hs | 101 ++++++++++-------------
 2 files changed, 44 insertions(+), 59 deletions(-)

diff --git a/Network/HTTP/Lucu/Dispatcher.hs b/Network/HTTP/Lucu/Dispatcher.hs
index 67838b0..7b0c840 100644
--- a/Network/HTTP/Lucu/Dispatcher.hs
+++ b/Network/HTTP/Lucu/Dispatcher.hs
@@ -8,6 +8,8 @@ module Network.HTTP.Lucu.Dispatcher
     , ResourceMap
     , ResourceTree
     , ResourceNode
+    , greedy
+    , nonGreedy
     )
     where
 import Network.HTTP.Lucu.Dispatcher.Internal
diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs
index 6cb741d..c889fc5 100644
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -1,17 +1,14 @@
 {-# LANGUAGE
-    DoAndIfThenElse
-  , ExistentialQuantification
+    ExistentialQuantification
+  , FlexibleContexts
   , FlexibleInstances
   , GeneralizedNewtypeDeriving
   , OverlappingInstances
   , MultiParamTypeClasses
-  , RecordWildCards
-  , ScopedTypeVariables
   , TemplateHaskell
   , UndecidableInstances
   , UnicodeSyntax
   #-}
-{-# OPTIONS_GHC -fno-warn-missing-methods #-}
 module Network.HTTP.Lucu.Dispatcher.Internal
     ( SchemeMapper(..)
     , SchemeMap
@@ -21,6 +18,8 @@ module Network.HTTP.Lucu.Dispatcher.Internal
     , ResourceMap
     , ResourceTree
     , ResourceNode
+    , greedy
+    , nonGreedy
 
     , dispatch
     )
@@ -75,17 +74,23 @@ class ResourceMapper α where
 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 
 -- |FIXME: doc
-newtype ResourceTree = Root ResourceNode
-    deriving (Monoid, Show)
+newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
+    deriving Monoid
 
--- |FIXME: docs
+-- |FIXME: doc
 data ResourceNode
-    = Greedy    !Resource !SubTree
-    | NonGreedy !Resource !SubTree
-    | Branch              !SubTree
+    = Greedy    { nResource ∷ !Resource }
+    | NonGreedy { nResource ∷ !Resource }
 
-type SubTree
-    = M.Map PathSegment ResourceNode
+-- |FIXME: doc
+greedy ∷ Resource → ResourceNode
+{-# INLINE CONLIKE greedy #-}
+greedy = Greedy
+
+-- |FIXME: doc
+nonGreedy ∷ Resource → ResourceNode
+{-# INLINE CONLIKE nonGreedy #-}
+nonGreedy = NonGreedy
 
 -- Instances of SchemeMapper --------------------------------------------------
 instance SchemeMapper SchemeMap where
@@ -252,58 +257,36 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
 -- Instances of ResourceTree --------------------------------------------------
 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
     {-# INLINEABLE insert #-}
-    insert (p, a) (Root b) = Root $ insertNodeAt (canonPath p) a b
+    insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
     {-# INLINE empty #-}
-    empty = Root $ Branch (∅)
+    empty = Tree (∅)
+    {-# INLINE singleton #-}
+    singleton = Tree ∘ singleton
 
 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 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 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)
+-- |'findResource' performs the longest prefix match on the tree,
+-- finding the most specific one.
+instance ResourceMapper ResourceTree where
+    {-# INLINEABLE findResource #-}
+    findResource p (Tree m)
+        = case lookup p m of
+            Just n  → return (p, nResource n)
+            Nothing → findGreedyResource p m
+
+findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode)
+                   ⇒ PathSegments
+                   → α
+                   → MaybeT m (PathSegments, Resource)
+findGreedyResource p m
+    = case back p of
+        Nothing      → fail (⊥)
+        Just (p', _) → case lookup p' m of
+                          Just (Greedy r)
+                              → return (p', r)
+                          _   → findGreedyResource p' m
 
 -- dispatch -------------------------------------------------------------------
 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
-- 
2.40.0