Network/HTTP/Lucu/Dispatcher/Node.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , UnicodeSyntax
   5   #-}
   6 module Network.HTTP.Lucu.Dispatcher.Node
   7     ( ResourceNode
   8     )
   9     where
  10 import Data.Collections
  11 import qualified Data.Map as M
  12 import Data.Monoid
  13 import Data.Monoid.Unicode
  14 import Network.HTTP.Lucu.Resource.Internal
  15 import Network.HTTP.Lucu.Utils
  16 import Prelude hiding (filter, null)
  17 import Prelude.Unicode
  18
  19 -- FIXME: docs
  20 data ResourceNode
  21     = Greedy    !Resource
  22     | NonGreedy !Resource !SubTree
  23     | Branch              !SubTree
  24
  25 type SubTree
  26     = M.Map PathSegment ResourceNode
  27
  28 instance Show ResourceNode where
  29     show (Greedy    _  ) = "Greedy _"
  30     show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m
  31     show (Branch      m) = "Branch " ⊕ show m
  32
  33 instance Monoid ResourceNode where
  34     {-# INLINE mempty #-}
  35     mempty = Branch (∅)
  36     {-# INLINEABLE mappend #-}
  37     mappend (Greedy    r  ) _               = Greedy    r
  38     mappend (NonGreedy r m) (Greedy    _  ) = NonGreedy r      m
  39     mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n)
  40     mappend (NonGreedy r m) (Branch      n) = NonGreedy r (m ⊕ n)
  41     mappend (Branch      _) (Greedy    r  ) = Greedy    r
  42     mappend (Branch      m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
  43     mappend (Branch      m) (Branch      n) = Branch      (m ⊕ n)
  44
  45 instance Unfoldable ResourceNode (PathSegments, ResourceNode) where
  46     {-# INLINEABLE insert #-}
  47     insert (p, n) = insertNodeAt (canonPath p) n
  48     {-# INLINE empty #-}
  49     empty = Branch (∅)
  50
  51 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
  52 {-# INLINEABLE canonPath #-}
  53 canonPath = filter ((¬) ∘ null)
  54
  55 insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode
  56 {-# INLINEABLE insertNodeAt #-}
  57 insertNodeAt p a b
  58     = case front p of
  59         Nothing         → a ⊕ b
  60         Just (x, xs)
  61             | null xs   → Branch (singleton (x, a)) ⊕ b
  62             | otherwise → insertNodeAt xs a (∅) ⊕ b
  63
  64 instance Foldable ResourceNode (PathSegments, ResourceNode) where
  65     foldMap f = go (∅)
  66         where
  67           go p (Greedy    r  ) = f (p, Greedy r)
  68           go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m
  69           go p (Branch      m) = go' p m
  70
  71           go' p = foldMap $ \(s, n) → go (p `snoc` s) n
  72
  73     null (Greedy    _  ) = False
  74     null (NonGreedy _ _) = False
  75     null (Branch      m) = null m