Simplify the implementation of ResourceTree

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

diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs
index f8f3b12e328df7f2f9d3057bf84f9d4c4c50963f..c889fc51dfae6683f2a6b10890ac7178f5860459 100644 (file)
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -1,11 +1,11 @@
 {-# LANGUAGE
-    DoAndIfThenElse
-  , ExistentialQuantification
+    ExistentialQuantification
+  , FlexibleContexts
   , FlexibleInstances
+  , GeneralizedNewtypeDeriving
   , OverlappingInstances
   , MultiParamTypeClasses
-  , RecordWildCards
-  , ScopedTypeVariables
+  , TemplateHaskell
   , UndecidableInstances
   , UnicodeSyntax
   #-}
@@ -18,6 +18,8 @@ module Network.HTTP.Lucu.Dispatcher.Internal
     , ResourceMap
     , ResourceTree
     , ResourceNode
+    , greedy
+    , nonGreedy
 
     , dispatch
     )
@@ -71,14 +73,24 @@ class ResourceMapper α where
 -- |Container type for the 'ResourceMapper' type class.
 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 
--- FIXME: doc
-newtype ResourceTree = Root ResourceNode
+-- |FIXME: doc
+newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
+    deriving Monoid
 
--- FIXME: docs
+-- |FIXME: doc
 data ResourceNode
-    = Greedy    !Resource
-    | NonGreedy !Resource !ResourceTree
-    | Branch              !ResourceTree
+    = Greedy    { nResource ∷ !Resource }
+    | NonGreedy { nResource ∷ !Resource }
+
+-- |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
@@ -116,7 +128,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
@@ -127,6 +139,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
@@ -168,7 +181,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
@@ -179,6 +192,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
@@ -213,7 +227,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
@@ -224,6 +238,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
@@ -239,57 +255,38 @@ 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
-    {-# INLINE insert #-}
-    insert e (Root root) = Root $ insert e root
-    {-# INLINE empty #-}
-    empty = (∅)
-
-instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) 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 ResourceTree (PathSegments, ResourceNode) where
     {-# INLINEABLE insert #-}
-    insert (p, a) b = insertNodeAt (canonPath p) a b
+    insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
     {-# INLINE empty #-}
-    empty = Branch (∅)
+    empty = Tree (∅)
+    {-# INLINE singleton #-}
+    singleton = Tree ∘ singleton
 
 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
-{-# 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
-    {-# 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)
--}
+-- |'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)