From: PHO <pho@cielonegro.org>
Date: Wed, 23 Nov 2011 14:34:02 +0000 (+0900)
Subject: Foldable ResourceNode
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=761b90ab4f413d2e83460f170082f3b15bbaef4f

Foldable ResourceNode

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---

diff --git a/Lucu.cabal b/Lucu.cabal
index 8703d04..9a3e296 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -119,6 +119,7 @@ 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 555ea85..dd37fb8 100644
--- a/Network/HTTP/Lucu/Dispatcher.hs
+++ b/Network/HTTP/Lucu/Dispatcher.hs
@@ -11,3 +11,4 @@ module Network.HTTP.Lucu.Dispatcher
     )
     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 71e5ffd..f86eb1f 100644
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -2,10 +2,12 @@
     DoAndIfThenElse
   , ExistentialQuantification
   , FlexibleInstances
+  , GeneralizedNewtypeDeriving
   , OverlappingInstances
   , MultiParamTypeClasses
   , RecordWildCards
   , ScopedTypeVariables
+  , TemplateHaskell
   , UndecidableInstances
   , UnicodeSyntax
   #-}
@@ -17,7 +19,6 @@ module Network.HTTP.Lucu.Dispatcher.Internal
     , ResourceMapper(..)
     , ResourceMap
     , ResourceTree
-    , ResourceNode
 
     , dispatch
     )
@@ -26,13 +27,14 @@ import Control.Applicative hiding (empty)
 import Control.Monad.Trans.Maybe
 import Control.Monad.Unicode
 import Data.Collections
-import qualified Data.Map as M
+import qualified Data.Collections.Newtype.TH as C
 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 (filter, lookup, null)
+import Prelude hiding (lookup)
 import Prelude.Unicode
 
 -- |FIXME: docs
@@ -73,15 +75,7 @@ data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 
 -- FIXME: doc
 newtype ResourceTree = Root ResourceNode
-
--- FIXME: docs
-data ResourceNode
-    = Greedy    !Resource
-    | NonGreedy !Resource !SubTree
-    | Branch              !SubTree
-
-type SubTree
-    = M.Map PathSegment ResourceNode
+    deriving (Monoid, Show)
 
 -- Instances of SchemeMapper --------------------------------------------------
 instance SchemeMapper SchemeMap where
@@ -242,50 +236,8 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 
 -- 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
-    {-# 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 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 (NonGreedy r m) (Branch      n) = NonGreedy r (m ⊕ n)
-    mappend (Branch      m) (Branch      n) = Branch      (m ⊕ n)
+C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode)
+           |]
 
 -- dispatch -------------------------------------------------------------------
 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
diff --git a/Network/HTTP/Lucu/Dispatcher/Node.hs b/Network/HTTP/Lucu/Dispatcher/Node.hs
new file mode 100644
index 0000000..84989d7
--- /dev/null
+++ b/Network/HTTP/Lucu/Dispatcher/Node.hs
@@ -0,0 +1,75 @@
+{-# 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