-{-# 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