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 f86eb1f4dacecf75bc5ef663e217b7828d208481..c889fc51dfae6683f2a6b10890ac7178f5860459 100644 (file)
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -1,12 +1,10 @@
 {-# LANGUAGE
-    DoAndIfThenElse
-  , ExistentialQuantification
+    ExistentialQuantification
+  , FlexibleContexts
   , FlexibleInstances
   , GeneralizedNewtypeDeriving
   , OverlappingInstances
   , MultiParamTypeClasses
-  , RecordWildCards
-  , ScopedTypeVariables
   , TemplateHaskell
   , UndecidableInstances
   , UnicodeSyntax
@@ -19,6 +17,9 @@ module Network.HTTP.Lucu.Dispatcher.Internal
     , ResourceMapper(..)
     , ResourceMap
     , ResourceTree
+    , ResourceNode
+    , greedy
+    , nonGreedy
 
     , dispatch
     )
@@ -27,14 +28,13 @@ import Control.Applicative hiding (empty)
 import Control.Monad.Trans.Maybe
 import Control.Monad.Unicode
 import Data.Collections
-import qualified Data.Collections.Newtype.TH as C
+import qualified Data.Map as M
 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 (lookup)
+import Prelude hiding (filter, lookup, null)
 import Prelude.Unicode
 
 -- |FIXME: docs
@@ -73,9 +73,24 @@ class ResourceMapper α where
 -- |Container type for the 'ResourceMapper' type class.
 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 
--- FIXME: doc
-newtype ResourceTree = Root ResourceNode
-    deriving (Monoid, Show)
+-- |FIXME: doc
+newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
+    deriving Monoid
+
+-- |FIXME: doc
+data ResourceNode
+    = 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
@@ -124,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
@@ -176,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
@@ -221,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
@@ -236,8 +255,38 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 
 -- Instances of ResourceTree --------------------------------------------------
-C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode)
-           |]
+instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
+    {-# INLINEABLE insert #-}
+    insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
+    {-# INLINE empty #-}
+    empty = Tree (∅)
+    {-# INLINE singleton #-}
+    singleton = Tree ∘ singleton
+
+canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
+{-# INLINEABLE canonPath #-}
+canonPath = filter ((¬) ∘ null)
+
+-- |'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)