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