Scrap SchemeMapper

[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 35f2f1ed403c81dfa36052d23b20b74995867628..72589200892f3f230cdf644082da384cd16a6dae 100644 (file)
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -10,9 +10,7 @@
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Dispatcher.Internal
-    ( SchemeMapper(..)
-    , SchemeMap
-    , HostMapper(..)
+    ( HostMapper(..)
     , HostMap
     , ResourceMapper(..)
     , ResourceMap
@@ -37,18 +35,6 @@ import Network.URI hiding (path)
 import Prelude hiding (filter, lookup, null)
 import Prelude.Unicode
 
--- |FIXME: docs
---
--- Minimal complete definition: 'findHostMap'
-class SchemeMapper α where
-    findHostMap ∷ Scheme → α → MaybeT IO HostMap
-    schemeMap   ∷ α → SchemeMap
-    {-# INLINE schemeMap #-}
-    schemeMap   = SMap
-
--- |Container type for the 'SchemeMapper' type class.
-data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
-
 -- |FIXME: docs
 --
 -- Minimal complete definition: 'findResourceMap'
@@ -65,7 +51,7 @@ data HostMap = ∀α. HostMapper α ⇒ HMap α
 --
 -- Minimal complete definition: 'findResource'
 class ResourceMapper α where
-    findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
+    findResource ∷ Path → α → MaybeT IO (Path, Resource)
     resourceMap  ∷ α → ResourceMap
     {-# INLINE resourceMap #-}
     resourceMap = RMap
@@ -87,7 +73,7 @@ data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 -- has no involvement in character encodings such as UTF-8, since RFC
 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
 -- in \"http\" and \"https\" URI schemas.
-newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
+newtype ResourceTree = Tree (M.Map Path ResourceNode)
     deriving Monoid
 
 -- |FIXME: doc
@@ -105,68 +91,6 @@ nonGreedy ∷ Resource → ResourceNode
 {-# INLINE CONLIKE nonGreedy #-}
 nonGreedy = NonGreedy
 
--- Instances of SchemeMapper --------------------------------------------------
-instance SchemeMapper SchemeMap where
-    {-# INLINE findHostMap #-}
-    findHostMap s (SMap α) = findHostMap s α
-    {-# INLINE schemeMap #-}
-    schemeMap = id
-
--- |'HostMap's are also 'SchemeMapper's too, which matches to any
--- schemes.
-instance SchemeMapper HostMap where
-    {-# INLINE findHostMap #-}
-    findHostMap = const return
-
--- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
--- schemes and hosts.
-instance SchemeMapper ResourceMap where
-    {-# INLINE findHostMap #-}
-    findHostMap _ r = return $ hostMap f
-        where
-          f ∷ Host → Maybe ResourceMap
-          {-# INLINE f #-}
-          f = const $ Just r
-
--- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
-instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
-    {-# INLINE insert #-}
-    insert a (SMap b) = schemeMap c
-        where
-          c ∷ Scheme → MaybeT IO HostMap
-          {-# INLINEABLE c #-}
-          c s = findHostMap s a <|> findHostMap s b
-    {-# INLINE empty #-}
-    empty = (∅)
-    {-# INLINE singleton #-}
-    singleton = schemeMap
-
--- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
-instance Monoid SchemeMap where
-    {-# INLINE mempty #-}
-    mempty = schemeMap e
-        where
-          e ∷ Scheme → MaybeT IO HostMap
-          {-# INLINE e #-}
-          e = const (fail (⊥))
-    {-# 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
-
--- |An IO-based scheme mapper.
-instance SchemeMapper (Scheme → MaybeT IO HostMap) where
-    {-# INLINE findHostMap #-}
-    findHostMap = flip id
-
--- |A pure scheme mapper.
-instance SchemeMapper (Scheme → Maybe HostMap) where
-    {-# INLINE findHostMap #-}
-    findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
-
 
 -- Instances of HostMapper ----------------------------------------------------
 instance HostMapper HostMap where
@@ -232,7 +156,7 @@ instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
     {-# INLINE insert #-}
     insert a (RMap b) = resourceMap c
         where
-          c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+          c ∷ Path → MaybeT IO (Path, Resource)
           {-# INLINEABLE c #-}
           c s = findResource s a <|> findResource s b
     {-# INLINE empty #-}
@@ -245,30 +169,30 @@ instance Monoid ResourceMap where
     {-# INLINE mempty #-}
     mempty = resourceMap e
         where
-          e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+          e ∷ Path → MaybeT IO (Path, Resource)
           {-# INLINE e #-}
           e = const (fail (⊥))
     {-# INLINE mappend #-}
     mappend = insert
 
--- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
--- are also 'ResourceMapper's.
-instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
+-- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also
+-- 'ResourceMapper's.
+instance Map α Path (Path, Resource) ⇒ ResourceMapper α where
     {-# INLINE findResource #-}
     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 
 -- |An IO-based resource mapper.
-instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
+instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where
     {-# INLINE findResource #-}
     findResource = flip id
 
 -- |A pure resource mapper.
-instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
+instance ResourceMapper (Path → Maybe (Path, Resource)) where
     {-# INLINE findResource #-}
     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 
 -- Instances of ResourceTree --------------------------------------------------
-instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
+instance Unfoldable ResourceTree (Path, ResourceNode) where
     {-# INLINEABLE insert #-}
     insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
     {-# INLINE empty #-}
@@ -289,10 +213,10 @@ instance ResourceMapper ResourceTree where
             Just n  → return (p, nResource n)
             Nothing → findGreedyResource p m
 
-findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode)
-                   ⇒ PathSegments
+findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
+                   ⇒ Path
                    → α
-                   → MaybeT m (PathSegments, Resource)
+                   → MaybeT m (Path, Resource)
 findGreedyResource p m
     = case back p of
         Nothing      → fail (⊥)
@@ -302,8 +226,7 @@ findGreedyResource p m
                           _   → findGreedyResource p' m
 
 -- dispatch -------------------------------------------------------------------
-dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
+dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
 dispatch uri
     = (findResource (uriPathSegments uri) =≪)
-      ∘ (findResourceMap (uriHost uri) =≪)
-      ∘ findHostMap (uriCIScheme uri)
+      ∘ findResourceMap (uriHost uri)