docs

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Lucu.cabal b/Lucu.cabal
index 9a3e2968d0d5b3266efde00f74f8cc94da6da762..8703d046dfa44c41b563d89a320fe50629990825 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -119,7 +119,6 @@ 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 dd37fb8c042ba84e273d4d72d65debca72463118..67838b03be91987b6e31d34b56039f4efca81141 100644 (file)
--- a/Network/HTTP/Lucu/Dispatcher.hs
+++ b/Network/HTTP/Lucu/Dispatcher.hs
@@ -5,10 +5,9 @@ module Network.HTTP.Lucu.Dispatcher
     , HostMapper(..)
     , HostMap
     , ResourceMapper(..)
+    , ResourceMap
     , ResourceTree
     , ResourceNode
-    , ResourceMap
     )
     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 f86eb1f4dacecf75bc5ef663e217b7828d208481..88b1e16cd07056110e78a93c440d89debcc10226 100644 (file)
--- a/Network/HTTP/Lucu/Dispatcher/Internal.hs
+++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs
@@ -11,6 +11,7 @@
   , UndecidableInstances
   , UnicodeSyntax
   #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
 module Network.HTTP.Lucu.Dispatcher.Internal
     ( SchemeMapper(..)
     , SchemeMap
@@ -19,6 +20,7 @@ module Network.HTTP.Lucu.Dispatcher.Internal
     , ResourceMapper(..)
     , ResourceMap
     , ResourceTree
+    , ResourceNode
 
     , dispatch
     )
@@ -27,14 +29,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,10 +74,19 @@ class ResourceMapper α where
 -- |Container type for the 'ResourceMapper' type class.
 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
 
--- FIXME: doc
+-- |FIXME: doc
 newtype ResourceTree = Root ResourceNode
     deriving (Monoid, Show)
 
+-- |FIXME: docs
+data ResourceNode
+    = Greedy    !Resource
+    | NonGreedy !Resource !SubTree
+    | Branch              !SubTree
+
+type SubTree
+    = M.Map PathSegment ResourceNode
+
 -- Instances of SchemeMapper --------------------------------------------------
 instance SchemeMapper SchemeMap where
     {-# INLINE findHostMap #-}
@@ -124,6 +134,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 +187,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 +233,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 +250,56 @@ 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, a) (Root b) = Root $ insertNodeAt (canonPath p) a b
+    {-# INLINE empty #-}
+    empty = Root $ 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 ResourceTree (PathSegments, ResourceNode) where
+    foldMap f (Root n) = go (∅) n
+        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 (Root (Greedy    _  )) = False
+    null (Root (NonGreedy _ _)) = False
+    null (Root (Branch      m)) = null m
+
+
+-- Instances of 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)
 
 -- dispatch -------------------------------------------------------------------
 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)

diff --git a/Network/HTTP/Lucu/Dispatcher/Node.hs b/Network/HTTP/Lucu/Dispatcher/Node.hs
deleted file mode 100644 (file)
index 84989d7..0000000
--- a/Network/HTTP/Lucu/Dispatcher/Node.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-{-# 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

diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
index 03fde6b714fde24a307005202ddb5564bd611a56..e1abcab63d8fc5344262f3cde0f14eec136347b8 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -46,6 +46,7 @@ import Prelude.Unicode
 -- >                  = Just $ do setContentType [mimeType| text/plain |]
 -- >                              putChunk "Hello, world!"
 -- >              }
+--
 -- FIXME: update the above example
 runHttpd ∷ Config → SchemeMap → IO ()
 runHttpd cnf sm