Foldable ResourceNode

[Lucu.git] / Network / HTTP / Lucu / Dispatcher / Node.hs

diff --git a/Network/HTTP/Lucu/Dispatcher/Node.hs b/Network/HTTP/Lucu/Dispatcher/Node.hs
new file mode 100644 (file)
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