From: PHO Date: Wed, 23 Nov 2011 14:34:02 +0000 (+0900) Subject: Foldable ResourceNode X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=761b90a;p=Lucu.git Foldable ResourceNode Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/Lucu.cabal b/Lucu.cabal index 8703d04..9a3e296 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -119,6 +119,7 @@ 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 555ea85..dd37fb8 100644 --- a/Network/HTTP/Lucu/Dispatcher.hs +++ b/Network/HTTP/Lucu/Dispatcher.hs @@ -11,3 +11,4 @@ module Network.HTTP.Lucu.Dispatcher ) 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 71e5ffd..f86eb1f 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -2,10 +2,12 @@ DoAndIfThenElse , ExistentialQuantification , FlexibleInstances + , GeneralizedNewtypeDeriving , OverlappingInstances , MultiParamTypeClasses , RecordWildCards , ScopedTypeVariables + , TemplateHaskell , UndecidableInstances , UnicodeSyntax #-} @@ -17,7 +19,6 @@ module Network.HTTP.Lucu.Dispatcher.Internal , ResourceMapper(..) , ResourceMap , ResourceTree - , ResourceNode , dispatch ) @@ -26,13 +27,14 @@ import Control.Applicative hiding (empty) import Control.Monad.Trans.Maybe import Control.Monad.Unicode import Data.Collections -import qualified Data.Map as M +import qualified Data.Collections.Newtype.TH as C 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 (filter, lookup, null) +import Prelude hiding (lookup) import Prelude.Unicode -- |FIXME: docs @@ -73,15 +75,7 @@ data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α -- FIXME: doc newtype ResourceTree = Root ResourceNode - --- FIXME: docs -data ResourceNode - = Greedy !Resource - | NonGreedy !Resource !SubTree - | Branch !SubTree - -type SubTree - = M.Map PathSegment ResourceNode + deriving (Monoid, Show) -- Instances of SchemeMapper -------------------------------------------------- instance SchemeMapper SchemeMap where @@ -242,50 +236,8 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where findResource = (maybe (fail (⊥)) return ∘) ∘ flip id -- Instances of ResourceTree -------------------------------------------------- -instance Unfoldable ResourceTree (PathSegments, ResourceNode) where - {-# INLINE insert #-} - insert e (Root root) = Root $ insert e root - {-# INLINE empty #-} - empty = (∅) - -instance Monoid ResourceTree where - {-# INLINE mempty #-} - mempty = Root (∅) - {-# INLINE mappend #-} - mappend (Root a) (Root b) - = Root (a ⊕ b) - --- Instances of ResourceNode -------------------------------------------------- -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 Monoid ResourceNode 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) +C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode) + |] -- dispatch ------------------------------------------------------------------- dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource) diff --git a/Network/HTTP/Lucu/Dispatcher/Node.hs b/Network/HTTP/Lucu/Dispatcher/Node.hs new file mode 100644 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